01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47 |
|
Private Sub Bild_Einfuegen_und_Anpassen_aus_Datei4()
' Sub fügt ein Bild in eine Zelle/Bereich ein
' Eingefügt an gewünschter Stelle, Höhe/Breite werden angepasst
Dim oPic As Object, AC As Range
Dim sPicFile As String, oShape As Object
Dim iZeile As Long, bBildda As Boolean
Const csPfad As String = "D:\Pictures\" ' Pfad <<<anpassen>>>
With ThisWorkbook.Sheets("Tabelle1")
For iZeile = 1 To .Cells(.Rows.Count, 3).End(xlUp).Row
If .Cells(iZeile, "C").Value <> "" Then
sPicFile = csPfad & .Cells(iZeile, "C").Value & ".jpg"
' Festellen, ob schon ein Bild in der Zelle drin ist
bBildda = False
For Each oShape In .Shapes
If oShape.TopLeftCell.Address = .Cells(iZeile, "A").Address Then
bBildda = True: Exit For
End If
Next oShape
If Dir$(sPicFile) <> "" And bBildda = False Then
' Bereich setzen, auch verbundene Zellen oder Range
Set AC = .Cells(iZeile, "A").MergeArea
' Bild einfügen
Set oPic = .Shapes.AddPicture(sPicFile, _
False, True, AC.Left + 1, AC.Top + 1, -1, -1)
If Not oPic Is Nothing Then
If oPic.Width > oPic.Height Then ' Querformat
oPic.Width = AC.Width - 2
If oPic.Height > AC.Height Then oPic.Height = AC.Height - 2
oPic.Top = AC.Top + ((AC.Height - oPic.Height) \ 2) ' zentrieren
Else
oPic.Height = AC.Height - 2 ' Hochformat
If oPic.Width > AC.Width Then oPic.Width = AC.Width - 2
oPic.Left = AC.Left + ((AC.Width - oPic.Width) \ 2) ' zentrieren
End If
Set oPic = Nothing
End If
End If
End If
Next iZeile
End With
End Sub
|