#1
Tahkikat Evrak Ekleri Ekleme 2021.rar
(Dosya Boyutu: 270,43 KB | İndirme Sayısı: 6)
Sub ImageEkle()
Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double
Set ws = ActiveSheet
imagePath = "D:\Desktop\Resimler 2021\images (3).jpg"
imgLeft = 3.7 * ws.Shapes("Resim 2").Left ' ActiveCell.Left
imgTop = ws.Shapes("Resim 2").Top 'ActiveCell.Top
imgWidth = ws.Shapes("Resim 2").Width
imgHeight = ws.Shapes("Resim 2").Height
'Width & Height = -1 means keep original size
'ws.Shapes("Resim 2").Delete
Set shp = ws.Shapes.AddPicture( _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=imgLeft, _
Top:=imgTop, _
Width:=imgWidth, _
Height:=imgHeight)
shp.Name = "DenemeResim"
End Sub
Sub ResimEkle(yol As String, sol As Double, topp As Double, gen As Double, yuk As Double, ad As String)
Dim obj As OLEObject
Set obj = ThisWorkbook.Sheets(Sayfa2.Name).OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, _
Left:=sol, _
Top:=topp, _
Width:=gen, _
Height:=yuk)
With obj.Object
.Picture = LoadPicture(yol)
.PictureSizeMode = fmPictureSizeModeStretch
End With
obj.Name = ad
Set obj = Nothing
End Sub
Sub resimSil(sayfaAd As Worksheet)
Dim obj As OLEObject
On Error Resume Next
For Each obj In sayfaAd.OLEObjects
If TypeOf obj.Object Is MSForms.Image Then
obj.Delete
End If
Next
On Error GoTo 0
Set obj = Nothing
End SubSub resim()
Dim fso As Object
On Error Resume Next
With ThisWorkbook.Sheets(Sayfa2.Name)
resimSil ThisWorkbook.Sheets(.Name)
say = 21
Set fso = CreateObject("Scripting.FileSystemObject")
For Each file In fso.GetFolder(ThisWorkbook.Path & "\Resimler 2021").Files
If LCase(fso.GetExtensionName(file)) <> "xlsm" Then
ResimEkle ThisWorkbook.Path & "\Resimler 2021\" & file.Name, _
.Cells(say, "j").Left, .Cells(say, "j").Top, .Cells(say, "j").Width, .Cells(say, "j").Height - 1 _
, fso.GetBaseName(file)
say = say + 1
End If
Next
End With
On Error GoTo 0
Set fso = Nothing
End SubSub ShpEkle()
Dim ws As Worksheet
Dim imagePath As String
Dim imgLeft As Double
Dim imgTop As Double
Dim imgWidth As Double
Dim imgHeight As Double
imgWidth = 229.3116
imgHeight = 223.9287
ekleLeft = 15
ekleTop = 16.071418762207
Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")
fPath = ThisWorkbook.Path & "\Resimler 2021\"
fName = Dir(fPath & "*.*") 'dosya ismi listesi
'ilk hücre "J21"
'.Offset (RowOffset, ColumnOffset)
x = 0
With ws.Range("J21")
Do While Len(fName) > 0
imagePath = fPath & fName
ws.Shapes.AddPicture _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=.Offset(Fix(x / 2), x Mod 2).Left + ekleLeft, _
Top:=.Offset(Fix(x / 2), x Mod 2).Top + ekleTop, _
Width:=imgWidth, _
Height:=imgHeight
x = x + 1
fName = Dir 'sonrak dosya adını al
Loop
End With
End Sub
Sub ShpSil()
Dim shp As Shape
Set ws = ThisWorkbook.Worksheets("Tahkikat Ekleri")
For Each shp In ws.Shapes
shp.Delete
Next shp
End Sub
