'***********************************************************
Sub Excel_BildEinfuegenInZelleA1()
->Das Makro
->a) fügt in die Zelle A1 des aktuellen Blattes ein Bild ein,
-> das an diese Zelle gebunden wird.
->b) Zeilenhöhe wird entsprechend der Bildhöhe gesetzt.
-> Wird dabei eine maximale Höhe c_MAXBILDHOEHE überschritten,
-> wird die Bildhöhe darauf reduziert.
->c) Spalte der betreffenden Zelle wird auf die sich dann ergebende Bildbreite erweitert,
-> wenn das Bild nach der Skalierung breiter als die Spalte ist.
->
->Voraussetzung:
-> - die Zelle A1 darf nicht bereits ein Bild enthalten
Const cFULLPATH_BILD = C:\Test\TestBild.jpg
Const c_MAXBILDHOEHE = 150-> max. Bildhöhe in Punkten
Const c_SICHERHEITSFAKTOR_BILDBREITE = 1.02
Dim ws As Worksheet, o_Bild As Picture, sh As Shape
Dim s_DateinameFull As String, b_IstBild As Boolean
Dim x1 As Long, l_Spalte As Long, lRow As Long, lCol As Long
Dim l_faktor As Double, d_ColWidth As Double
Dim d_colWidth_Pkt As Double, d_BildWidth_Pkt As Double
Dim lCount As Long
->voller Pfad zum Bild
s_DateinameFull = cFULLPATH_BILD
If Dir(s_DateinameFull, vbNormal) = Then
MsgBox Bild-> & s_DateinameFull &-> nicht vorhanden.
GoTo AUFRAEUMEN
End If
->*** na dann an die Arbeit
Set ws = ActiveSheet
lRow = ActiveSheet.Range(A1).Row
lCol = ActiveSheet.Range(A1).Column
->*** pruefen, ob Zelle bereits ein Bild enthält
On Error Resume Next
For Each sh In ws.Shapes
l_Spalte = sh.TopLeftCell.Column
If Err.Number = 0 Then
If l_Spalte = lCol Then
If sh.TopLeftCell.Row = lRow Then
MsgBox Die selektierte Zelle enthält bereits ein Bild.
GoTo AUFRAEUMEN
End If
End If
Else
Err.Clear
End If
Next
On Error GoTo 0
->alten Zellinhalt entfernen
ws.Cells(lRow, lCol).Value =
->*** Bild eintragen
->Zelle markieren, Bild einfügen
ws.Range(A1).Select
On Error Resume Next
ws.Cells(lRow, lCol).Select
ws.Pictures.Insert (s_DateinameFull)
Set o_Bild = ws.Pictures(ws.Pictures.Count)
If Err.Number <> 0 Then
Err.Clear
MsgBox Das Bild & s_DateinameFull & konnte nicht eingefügt werden.
GoTo AUFRAEUMEN
End If
On Error GoTo 0
o_Bild.Placement = xlMove->xlFreeFloating
o_Bild.PrintObject = True
->Bildhöhe begrenzen
If o_Bild.Height > c_MAXBILDHOEHE Then
->skalieren
l_faktor = c_MAXBILDHOEHE / o_Bild.Height
o_Bild.ShapeRange.ScaleWidth l_faktor, msoFalse, msoScaleFromTopLeft
o_Bild.ShapeRange.ScaleHeight l_faktor, msoFalse, msoScaleFromTopLeft
End If
->Zeilenhöhe dem Bild anpassen
ws.Rows(lRow).RowHeight = o_Bild.Height
->Breite der Spalte anpassen, wenn Bild breiter als Spalte
d_ColWidth = ws.Cells(lRow, lCol).ColumnWidth
d_colWidth_Pkt = ws.Cells(lRow, lCol).Width->in Punkt
d_BildWidth_Pkt = o_Bild.ShapeRange.Width 'in Punkt
->kleiner Koorekturfaktor, damit Bild nicht über den rand hinausschaut
d_BildWidth_Pkt = d_BildWidth_Pkt * c_SICHERHEITSFAKTOR_BILDBREITE
->Bild breiter als Spalte - > Spalte auf Bild-Breite
If d_BildWidth_Pkt > d_colWidth_Pkt Then
->Bilder dieser Spalte auf xlMove, damit sie nicht verzerrt werden
On Error Resume Next
For Each sh In ws.Shapes
l_Spalte = sh.TopLeftCell.Column
If Err.Number = 0 Then
If l_Spalte = lCol Then sh.Placement = xlMove
Else
Err.Clear
End If
Next
On Error GoTo 0
->Splate Breite anpassen
d_ColWidth = d_BildWidth_Pkt / d_colWidth_Pkt * d_ColWidth * c_SICHERHEITSFAKTOR_BILDBREITE
ws.Columns(lCol).ColumnWidth = d_ColWidth
->Bilder dieser Spalte wieder auf xlMoveAndSize
On Error Resume Next
For Each sh In ws.Shapes
l_Spalte = sh.TopLeftCell.Column
If Err.Number = 0 Then
If l_Spalte = lCol Then
sh.Placement = xlMoveAndSize
End If
Else
Err.Clear
End If
Next
On Error GoTo 0
End If
->Um Bild mit Spalte ausblenden zu können, Bild mit Zelle verbinden
o_Bild.Placement = xlMoveAndSize
AUFRAEUMEN:
Set ws = Nothing: Set o_Bild = Nothing: Set sh = Nothing
End Sub
)