- Katılım
- 7 Şubat 2024
- Mesajlar
- 14
- Excel Vers. ve Dili
- Microsoft Office Professional Plus 2016
Merhaba rica etsem aşağıdaki sorunumu çözer misiniz? Şimdiden çok teşekkür ederin.
Açıklama:
İstenilen:
KOD1------------------------------------------------------------------------------------------------------------
Sub PicWithCaption()
Dim xFileDialog As FileDialog
Dim xPath, xFile As Variant
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDialog.Show = -1 Then
xPath = xFileDialog.SelectedItems.Item(1)
If xPath <> "" Then
xFile = Dir(xPath & "\.")
Do While xFile <> ""
If UCase(Right(xFile, 3)) = "PNG" Or _
UCase(Right(xFile, 3)) = "TIF" Or _
UCase(Right(xFile, 3)) = "JPG" Or _
UCase(Right(xFile, 3)) = "GIF" Or _
UCase(Right(xFile, 3)) = "BMP" Then
With Selection
.InlineShapes.AddPicture xPath & "\" & xFile, False, True
.InsertAfter vbCrLf
.MoveDown wdLine
.Text = Left(xFile, InStrRev(xFile, ".") - 1) & Chr(10)
.MoveDown wdLine
End With
End If
xFile = Dir()
Loop
End If
End If
End Sub
KOD2-----------------------------------------------------------------------------------------------------------
Sub GenislikAyarla()
genislik = 10
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.Height = AspectHt(.Width, .Height, CentimetersToPoints(genislik))
.Width = CentimetersToPoints(genislik)
End With
Next i
End With
End Sub
Private Function AspectHt(ByVal origWd As Long, ByVal origHt As Long, ByVal newWd As Long) As Long
If origWd <> 0 Then
AspectHt = (CSng(origHt) / CSng(origWd)) * newWd
Else
AspectHt = 0
End If
End Function
Açıklama:
- Kod1 resimleri toplu olarak adlarıyla beraber ekleme işlmemi yapıyor
- Kod2 resimlerin genişliklerini ayarlıyor (referans olarak kullanıla bilir)
İstenilen:
- tek kod ile resimler eklensin (kod 1 yapıyor)
- resimlerin adları altında yazacak ve resmin ortasında yer alacak
- resimler eklenirken benim belirlediğim genişlik ve yükseklik ölçülerinde eklenecek
- üstteki 3 aşama tek kodda birleşecek
KOD1------------------------------------------------------------------------------------------------------------
Sub PicWithCaption()
Dim xFileDialog As FileDialog
Dim xPath, xFile As Variant
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDialog.Show = -1 Then
xPath = xFileDialog.SelectedItems.Item(1)
If xPath <> "" Then
xFile = Dir(xPath & "\.")
Do While xFile <> ""
If UCase(Right(xFile, 3)) = "PNG" Or _
UCase(Right(xFile, 3)) = "TIF" Or _
UCase(Right(xFile, 3)) = "JPG" Or _
UCase(Right(xFile, 3)) = "GIF" Or _
UCase(Right(xFile, 3)) = "BMP" Then
With Selection
.InlineShapes.AddPicture xPath & "\" & xFile, False, True
.InsertAfter vbCrLf
.MoveDown wdLine
.Text = Left(xFile, InStrRev(xFile, ".") - 1) & Chr(10)
.MoveDown wdLine
End With
End If
xFile = Dir()
Loop
End If
End If
End Sub
KOD2-----------------------------------------------------------------------------------------------------------
Sub GenislikAyarla()
genislik = 10
With ActiveDocument
For i = 1 To .InlineShapes.Count
With .InlineShapes(i)
.Height = AspectHt(.Width, .Height, CentimetersToPoints(genislik))
.Width = CentimetersToPoints(genislik)
End With
Next i
End With
End Sub
Private Function AspectHt(ByVal origWd As Long, ByVal origHt As Long, ByVal newWd As Long) As Long
If origWd <> 0 Then
AspectHt = (CSng(origHt) / CSng(origWd)) * newWd
Else
AspectHt = 0
End If
End Function
