DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Function Resim(ByVal resad As String, Optional ByVal gen As Single = 200, _
Optional ByVal yuk As Single = 150)
Dim hcr As Range
Dim res As Object
Set hcr = Application.Caller
For Each res In hcr.Parent.Pictures
If res.TopLeftCell.Address = hcr.Address Then
res.Delete
Exit For
End If
Next
Set res = hcr.Parent.Pictures.Insert(resad)
With res
.Left = hcr.Left + 1
.Top = hcr.Top + 1
.Width = gen
.Height = yuk
End With
End Function
Sub deneme1()
sat1 = 3 'İlk satır
sat2 = 9 'Son satır
sut1 = "I" 'İlk sütun
sut2 = "J" 'Son sütun
Set Adres = Range(Cells(sat1, sut1), Cells(sat2, sut2))
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
Exit For
End If
End If
Next Picture
klasor = ThisWorkbook.Path & "\Resimler\"
isim = Cells(12, "C").Value
ReDim uzanti(12)
uzanti(1) = ".bmp": uzanti(2) = ".jpg"
uzanti(3) = ".gif": uzanti(4) = ".pcx"
uzanti(5) = ".tga": uzanti(6) = ".emf"
uzanti(7) = ".abm": uzanti(8) = ".avi"
uzanti(9) = ".png": uzanti(10) = ".jpeg"
uzanti(11) = ".wmf": uzanti(12) = ".TIFF"
For i = 1 To 12
If CreateObject("Scripting.FileSystemObject").FileExists(klasor & isim & uzanti(i)) = True Then
ActiveSheet.Pictures.Insert(klasor & isim & uzanti(i)).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3
Exit For
Cells(1, 1).Select
End If
Next
End Sub