• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

sayfadaki resimler

meleklerim

meleklerim

Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
İyi akşamlar arkadaşlar
bir excel sayfamda personel kimlik bilgilerini olduğu sütunlar var. Bu sütunlardan birine de personllerin "resim ekle" menüsü kullanarak eklenmiş resimleri var. Bana sadece o resimler lazım. Herhangi bir makro ile o resimleri bir klasöre ayrı ayrı "resim olarak" kaydetmek mümkün mü? Ya da başka yol? Tek tek elle yapmak istemiyorum yaklaşık 1000 kişi var
selamlar
 
meleklerim' Alıntı:
İyi akşamlar arkadaşlar
bir excel sayfamda personel kimlik bilgilerini olduğu sütunlar var. Bu sütunlardan birine de personllerin "resim ekle" menüsü kullanarak eklenmiş resimleri var. Bana sadece o resimler lazım. Herhangi bir makro ile o resimleri bir klasöre ayrı ayrı "resim olarak" kaydetmek mümkün mü? Ya da başka yol? Tek tek elle yapmak istemiyorum yaklaşık 1000 kişi var
selamlar
Genişletmek için tıkla ...

10-15 adet resim olan örnek dosyanızı ekleyin bir bakalım

ayrıca resimlerin adı ne olacak onuda belirtin.
 
Altın üye olmadığımdan malesef örnek dosya ekleyemiyorum. Resim isimleri önemli değili 1,2,3 şeklinde olabilir
 
meleklerim' Alıntı:
Altın üye olmadığımdan malesef örnek dosya ekleyemiyorum. Resim isimleri önemli değili 1,2,3 şeklinde olabilir
Genişletmek için tıkla ...

Bir çok mesaj yazmamak için örnek dosyanızı istemiştim.

Aşağıdaki kodu bir modülün içine kopyalayın.

Kod: 
Option Explicit
Option Compare Text


#If Win64 Then
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

#Else
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

#End If

#If VBA7 Then

#Else
#End If



Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

Const CF_BITMAP = 2
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture

Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long
lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
h = OpenClipboard(0&)
If h > 0 Then
hPtr = GetClipboardData(lPicType)
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
h = CloseClipboard
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If

End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture

With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(lPicType = CF_BITMAP, 1, 4)
.hPic = hPic
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
End With

r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
Set CreatePicture = IPic

End Function

Private Function fnOLEError(lErrNum As Long) As String

Select Case lErrNum
Case &H80004004
fnOLEError = " Aborted"
Case &H80070005
fnOLEError = " Access Denied"
Case &H80004005
fnOLEError = " General Failure"
Case &H80070006
fnOLEError = " Bad/Missing Handle"
Case &H80070057
fnOLEError = " Invalid Argument"
Case &H80004002
fnOLEError = " No Interface"
Case &H80004001
fnOLEError = " Not Implemented"
Case &H8007000E
fnOLEError = " Out of Memory"
Case &H80004003
fnOLEError = " Invalid Pointer"
Case &H8000FFFF
fnOLEError = " Unknown Error"
Case &H0
fnOLEError = " Success!"
End Select

End Function

bu koduda başka bir modüle kopyalayın ve çalıştırın.
kod 50 adette uyarı verecektir.


Kod: 
Sub resimkaydet()
Dim sat, sat1
sat1 = 0

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Application.DisplayAlerts = False


Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
sat = fL.GetFolder(Kaynak).Files.Count


Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

sat = sat + 1 'Picture.BottomRightCell.Row
dosyaadı = Format(sat, "000") & "-Resim" & ".jpg"

ActiveSheet.Shapes(Picture.Name).Select
ActiveSheet.Shapes(Picture.Name).CopyPicture
SavePicture PastePicture, Kaynak & dosyaadı

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("00:00:05"))
'MsgBox "devam et"
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0

End If
End If
Next Picture

Application.DisplayAlerts = True
CreateObject("WScript.Shell").Popup "işlem tamam", 1, " UYARI!", vbOKOnly + vbInformation

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"

End If
End Sub
 
ekledim, modülü çalıştırdım. klasör istedi, gösterdim

aniak şu satıra hatalı dedi (kımızı ile belirttim)

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
 
siz bir excel sayfasına bu modülleri ekleyip gönderseniz, ben sizin gönderdiğiniz belgeye resimlerin olduğu sayfayı taşısam mümkün mü acaba?
 
meleklerim' Alıntı:
siz bir excel sayfasına bu modülleri ekleyip gönderseniz, ben sizin gönderdiğiniz belgeye resimlerin olduğu sayfayı taşısam mümkün mü acaba?
Genişletmek için tıkla ...

Size söylemiştim örnek dosyanızı ekleseydiniz daha kolay olacaktı.

Ekli dosyayı indirin ve uzantısını .xls olarak değiştirin.
eğer kod hata veriyorsa hata veren bölüme bunu ekleyin.

Kod: 
[COLOR="Red"]PtrSafe[/COLOR]

Kod: 
Private Function

Kod: 
Private [COLOR="Red"]PtrSafe[/COLOR] Function


siyah bölüme kırmızı bölümü ekleyin.
 
Arkadaşım sana da çok zahmet verdim biliyorum, ancak bu sefer de başka bir satırda hata verdi. Ben dosyayı siteye yükleyemiyorum ama başk bir servere up yapıp linkini veriyorum (niye daha önce akıl edemedim diye de kendime kızdım) Bu belgeyi indirip modülü eklersen çok memnun olacağım.

https://mega.co.nz/#!OR5EnRiC!ZQ-essbsWj9tapmc8TS43k5AYsvXG_PsKtEUIHqgE1c
 
meleklerim' Alıntı:
Arkadaşım sana da çok zahmet verdim biliyorum, ancak bu sefer de başka bir satırda hata verdi. Ben dosyayı siteye yükleyemiyorum ama başk bir servere up yapıp linkini veriyorum (niye daha önce akıl edemedim diye de kendime kızdım) Bu belgeyi indirip modülü eklersen çok memnun olacağım.
Genişletmek için tıkla ...

Dosyanı indirdim linkini silebilirsin
ben ofis 2003 de denedim kod çalışıyor görsel videoyu da birazdan ekliyeceğim şimdi yükleme yapıyorum.

kod:

Kod: 
Option Explicit
#Const Develop = True
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
  Size As Long
  Type As Long
#If Win64 Then
  hPic As LongPtr
#Else
  hPic As Long
#End If
  hPal As Long
End Type
#If Win64 Then
'Does the clipboard contain a bitmap/metafile?
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" ( _
  ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
'Close the clipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
'Convert the handle into an OLE IPicture interface.
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
  PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As LongPtr
'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
  ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
Private Declare PtrSafe Function CopyImage Lib "user32" ( _
  ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
  ByVal un2 As Long) As LongPtr
#Else
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
#If VBA7 Then
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" ( _
  PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#Else
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" ( _
  PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" ( _
  ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" ( _
  ByVal handle As Long, ByVal imageType As Long, ByVal newWidth As Long, ByVal newHeight As Long, _
  ByVal lFlags As Long) As Long
#End If
'The API format types we're interested in
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
#If Develop Then
Sub Test()

  With Sheets(1)
    'Copy and paste as enhanced Metafile
    .Range("A1:D5").CopyPicture
    .Image1.Picture = PastePicture
    
    'Copy and paste as Bitmap
    .Range("A1:D5").CopyPicture , xlBitmap
    .Image2.Picture = PastePicture
  End With
End Sub
#End If
Function PastePicture() As IPicture
  'Some pointers
  Dim h As Long, lPicType As Long
  #If Win64 Then
  Dim hPtr As LongPtr, hCopy As LongPtr
  #Else
  Dim hPtr As Long, hCopy As Long
  #End If
  
  'Check if the clipboard contains a possible format
  If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
    lPicType = CF_BITMAP
  ElseIf IsClipboardFormatAvailable(CF_ENHMETAFILE) <> 0 Then
    lPicType = CF_ENHMETAFILE
  End If
  If lPicType <> 0 Then
    'Get access to the clipboard
    h = OpenClipboard(0&)
    If h > 0 Then
      'Get a handle to the image data
      hPtr = GetClipboardData(lPicType)
      'Create our own copy of the image on the clipboard, in the appropriate format.
      If lPicType = CF_BITMAP Then
        hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
      Else
        hCopy = CopyEnhMetaFile(hPtr, vbNullString)
      End If
      'Release the clipboard to other programs
      h = CloseClipboard
      'If we got a handle to the image, convert it into a Picture object and return it
      If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
    End If
  End If
End Function
#If Win64 Then
Private Function CreatePicture(ByVal hPic As LongPtr, ByVal hPal As Long, ByVal lPicType) As IPicture
  Dim r As LongPtr
#Else
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
  Dim r As Long
#End If
  ' IPicture requires a reference to "OLE Automation"
  Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
  'OLE Picture types
  Const PICTYPE_BITMAP = 1
  Const PICTYPE_ENHMETAFILE = 4
  ' Create the Interface GUID (for the IPicture interface)
  With IID_IDispatch
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4(0) = &H8B
    .Data4(1) = &HBB
    .Data4(2) = &H0
    .Data4(3) = &HAA
    .Data4(4) = &H0
    .Data4(5) = &H30
    .Data4(6) = &HC
    .Data4(7) = &HAB
  End With
  ' Fill uPicInfo with necessary parts.
  With uPicInfo
    .Size = Len(uPicInfo) ' Length of structure.
    .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture
    .hPic = hPic ' Handle to image.
    .hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).
  End With
  ' Create the Picture object.
  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
  ' If an error occured, show the description
  If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)
  ' Return the new Picture object.
  Set CreatePicture = IPic
End Function
Private Function fnOLEError(lErrNum As Long) As String
  'OLECreatePictureIndirect return values
  Const E_ABORT = &H80004004
  Const E_ACCESSDENIED = &H80070005
  Const E_FAIL = &H80004005
  Const E_HANDLE = &H80070006
  Const E_INVALIDARG = &H80070057
  Const E_NOINTERFACE = &H80004002
  Const E_NOTIMPL = &H80004001
  Const E_OUTOFMEMORY = &H8007000E
  Const E_POINTER = &H80004003
  Const E_UNEXPECTED = &H8000FFFF
  Const S_OK = &H0
  Select Case lErrNum
    Case E_ABORT
      fnOLEError = " Aborted"
    Case E_ACCESSDENIED
      fnOLEError = " Access Denied"
    Case E_FAIL
      fnOLEError = " General Failure"
    Case E_HANDLE
      fnOLEError = " Bad/Missing Handle"
    Case E_INVALIDARG
      fnOLEError = " Invalid Argument"
    Case E_NOINTERFACE
      fnOLEError = " No Interface"
    Case E_NOTIMPL
      fnOLEError = " Not Implemented"
    Case E_OUTOFMEMORY
      fnOLEError = " Out of Memory"
    Case E_POINTER
      fnOLEError = " Invalid Pointer"
    Case E_UNEXPECTED
      fnOLEError = " Unknown Error"
    Case S_OK
      fnOLEError = " Success!"
  End Select
End Function

ikinci kod:

Kod: 
Sub resimkaydet()
Dim sat, sat1
sat1 = 0
  
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Application.DisplayAlerts = False
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes

If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then

Picture.OLEFormat.Object.Top = Picture.OLEFormat.Object.Top + 6
Picture.OLEFormat.Object.Left = Picture.OLEFormat.Object.Left + 6
Picture.OLEFormat.Object.ShapeRange.Height = Picture.OLEFormat.Object.ShapeRange.Height - 30
Picture.OLEFormat.Object.ShapeRange.Width = Picture.OLEFormat.Object.ShapeRange.Width - 30

Set Adres = Cells(Picture.BottomRightCell.Row, Picture.BottomRightCell.Column)

Picture.OLEFormat.Object.Top = Adres.Top + 4
Picture.OLEFormat.Object.Left = Adres.Left + 4
Picture.OLEFormat.Object.Height = Adres.Height - 7
Picture.OLEFormat.Object.Width = Adres.Width - 7

sat = Picture.BottomRightCell.Row + 1
sut = Picture.BottomRightCell.Column - 1
dosyaadı = Trim(Mid(Cells(sat, sut).Value, 12, 50)) & ".jpg"

Picture.Select
Picture.CopyPicture
SavePicture PastePicture, Kaynak & dosyaadı

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("00:00:05"))
MsgBox "devam et"
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0

End If
End If
Next Picture

Application.DisplayAlerts = True
CreateObject("WScript.Shell").Popup "işlem tamam", 1, " UYARI!", vbOKOnly + vbInformation

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"

End If
End Sub
 
Bu görsel video
 
sizde olduğu kesiin. zaten videodan da anlaşılıyor. Aslında tam da istediğim gibi olmuş. /simler de olmuş. Ama bende çalışmıyor. Şimdi de
If r <> 0 Then Debug.Print "Create Picture: "....... (r) satırında kırmızı ile işaretledim yerde hata gösteriyor. sanırım versiyon farkı. Yoksa aynen yapıyorum.
Size dosyanın tamamnın göndersem. siz fotoları çıkarıp bana foto kalsörünü bana up etseniz ... yoksa bu kadar sizin çabanız da boşa gidecek. Mümkün mü acaba?

https://mega.co.nz/#!mIgCAIQK!Y6AspnrW99FV1DkYhmzDIYGWGkTm-5Sy5DXTNnIIB4M
 
meleklerim' Alıntı:
sizde olduğu kesiin. zaten videodan da anlaşılıyor. Aslında tam da istediğim gibi olmuş. /simler de olmuş. Ama bende çalışmıyor. Şimdi de
If r <> 0 Then Debug.Print "Create Picture: "....... (r) satırında kırmızı ile işaretledim yerde hata gösteriyor. sanırım versiyon farkı. Yoksa aynen yapıyorum.
Size dosyanın tamamnın göndersem. siz fotoları çıkarıp bana foto kalsörünü bana up etseniz ... yoksa bu kadar sizin çabanız da boşa gidecek. Mümkün mü acaba?
Genişletmek için tıkla ...

Eklemiş olduğunuz linkleri silin ben dosyanızı indirdim.

ekli dosyayı indirin ve (.avi) uzantısını (.rar) olarak değiştirin


bu kod da dosyadaki resimleri sayfaya ilgili yerlere ekliyor.
tabi önce resimleri silmek gerekiyor.

Kod: 
Sub resimlerisil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
End Sub

Sub resimlerigetir()

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
ActiveSheet.Shapes(Picture.Name).Select
sat = Picture.BottomRightCell.Row
Picture.Delete
End If
Next Picture

For r = 2 To Cells(Rows.Count, "a").End(3).Row

If Trim(Mid(Cells(r, 1).Value, 1, 3)) = "Adı" Then

sut = 1

For i = 1 To 3
isim = Trim(Mid(Cells(r, sut).Value, 12, 50))
Set Adres = Range(Cells(r - 1, sut + 1), Cells(r - 1, sut + 1))

If CreateObject("Scripting.FileSystemObject").FileExists(Kaynak & isim & ".jpg") = True Then
Cells(r, sut).Select
ActiveSheet.Pictures.Insert(Kaynak & isim & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 4
Selection.Left = Adres.Left + 4
Selection.ShapeRange.Height = Adres.Height - 6
Selection.ShapeRange.Width = Adres.Width - 6
Selection.ShapeRange.Name = isim

End If
sut = sut + 3
Next
End If
Next

Range("a1").Select
CreateObject("WScript.Shell").Popup "işlem tamam", 1, " UYARI!", vbOKOnly + vbInformation

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
 
çok teşekkrüler, resimleri aldım. Allah razı olsun, iyi bayramlar
Not: Kod yine çalışmadı, ama artık önemi yok :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst