Bilder einfügen
30.11.2017 06:38:21
Tippi
Ich habe mal wieder ein Problem und zwar habe ich ein Code den ich schon mit eurer Hilfe erstellt habe der auch super läuft nur das wenn ich die Datei verschicke die Bilder alle weg sind.
Wie muss ich mein Code umstellen das die Bilder mit verschickt werden
Danke schon mal für eure Hilfe
Hier mein Code
Sub insertPicturesTest()
Dim objPic As Object
Dim lngRow As Long, lngLast As Long
Dim dblOHeight As Double, dblOWidth As Double
Dim strFile As String
Dim S
For Each S In ActiveSheet.Shapes
If Not Intersect(S.TopLeftCell, Range("F:F")) Is Nothing Then S.Delete
Next S
Const cstrPath As String = "R:\Logistik\" 'Pfad
Const cstrExtention As String = ".jpg"
With Sheets("Tabelle1") 'Tabellenname anpassen!
lngLast = Application.Max(1, .Cells(.Rows.Count, 2).End(xlUp).Row)
For lngRow = 11 To lngLast
If .Cells(lngRow, 2) "" Then
strFile = Dir(cstrPath & IIf(Right(cstrPath, 1) = "\", "", "\") & .Cells(lngRow, 2) & _
cstrExtention, vbNormal)
If strFile "" Then
Set objPic = .Pictures.Insert(cstrPath & IIf(Right(cstrPath, 1) = "\", "", "\") & _
strFile)
objPic.Top = .Cells(lngRow, 1).Top
objPic.Left = .Cells(lngRow, 6).Left
dblOHeight = 10
dblOWidth = 10
objPic.ShapeRange.LockAspectRatio = False
objPic.Height = .Cells(lngRow, 2).Height
objPic.Width = dblOWidth * (objPic.Height / dblOHeight)
End If
End If
Next
End With
Set objPic = Nothing
End Sub