Bild ausschneiden und als jpg einfügen
10.07.2018 14:28:28
Matthias
für das Einfügen von Bildern im PNG-Format habe ich (irgendwo) den folgenden Code gefunden, der auch gut funktioniert. Das Problem der Pictures.Insert-Methode ist, dass hier nur die Links der Bilder hinterlegt sind. Ändert sich der Pfad oder die Bilder werden dort gelöscht, so werden die Bilder im Excel nicht mehr angezeigt.
Ich möchte den Code so ändern, dass die Bilder gleich im JPG-Format eingebettet werden (nicht nur verlinken) oder mit der Pictures.Insert-Methode zunächst eingefügt, dann ausgeschnitten und an gleicher Position als JPG wieder eingefügt werden.
Kann mir dabei jemand helfen? Meine bisherigen Versuche sind bislang alle gescheitert.
Option Explicit
Private Const IMAGE_HEIGHT As Long = 130 'Bildhöhe
Private Const FIRST_IMAGE_TOP As Long = 1 'Startposition von oben
Private Const FIRST_IMAGE_LEFT As Long = 0 'Startposition von links
Private Const SPACE_H As Long = 5 'Horizontaler Abstand
Private Const SPACE_V As Long = 5 'Vertikaler Abstand
Private Const MAX_IMAGES_IN_ROW As Long = 6 'Maximale Bilderanzahl pro Reihe
Sub BilderWeg()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
If LCase(Mid(sh.Name, 1, 3)) = "jpg" Then sh.Delete
' hier ggf. "pic" durch "jpg" ersetzen, siehe unten
Next
End Sub
Sub insertPictures()
Dim objImg As Object
Dim strPath As String, strImg As String
Dim dblTop As Double, dblLeft As Double, dblMaxWidth As Double
Dim lngIndex As Long, lngCalc As Long, hoehe As Long
Dim filelist() As String
Dim folder
Dim datein, z As Long, i As Long
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
hoehe = FIRST_IMAGE_TOP + ActiveCell.Top
dblTop = hoehe
dblLeft = FIRST_IMAGE_LEFT
strPath = fncBrowseForFolder
If Len(strPath) Then
' ActiveSheet.Shapes.SelectAll ' warum? Zum Überschreiben bzw. Löschen?
strPath = strPath & "\"
strImg = Dir(strPath & "*.PNG", vbNormal)
Do While strImg ""
z = z + 1
Range("A" & z) = strImg
strImg = Dir
Loop
If z > 0 Then BilderWeg
Range("A1").Resize(z).Sort Range("A1"), xlAscending, Header:=xlNo
datein = Range("A1").Resize(z)
Range("A1").Resize(z).Clear
For i = 1 To z
Set objImg = ActiveSheet.Pictures.Insert(strPath & datein(i, 1))
With objImg
.ShapeRange.LockAspectRatio = msoTrue
.Height = IMAGE_HEIGHT
.Left = dblLeft
.Top = dblTop
.Name = "JpgImport_" & i ' *** siehe unten
.ShapeRange.Rotation = 0
lngIndex = lngIndex + 1
dblMaxWidth = Application.Max(dblMaxWidth, .Width)
End With
If lngIndex Mod MAX_IMAGES_IN_ROW = 0 Then
dblTop = dblTop + IMAGE_HEIGHT + SPACE_V
dblLeft = FIRST_IMAGE_LEFT
Else
dblLeft = dblLeft + dblMaxWidth + SPACE_H
dblMaxWidth = 0
End If
Next
End If
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'insertPictures'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Modul - Modul1"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
.DisplayAlerts = True
End With
Set objImg = Nothing
End Sub
Private Function fncBrowseForFolder(Optional ByVal defaultPath = "u:") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object
Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)
If objFlder Is Nothing Then GoTo ErrExit
Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path
ErrExit:
Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function
Matthias