AW: Bild in akive Zelle kopieren
04.02.2015 11:00:18
yummi
Hallo Stef,
hatte mal so was gemacht:
Function GraphicfileInZelleEinfuegen(lngZeile As Long, lngSpalte As Long, strDatei As String, _
Optional strPfad As String = "")
Dim shpNeu As Object
Dim iFaktor As Integer
Dim wksTabelle As Worksheet
Dim rng As Range
Set wksTabelle = ActiveSheet
iFaktor = wksTabelle.Cells(lngZeile, lngSpalte).MergeArea.Columns.Count
If strPfad = "" Then
strPfad = ActiveWorkbook.Path
End If
If Right(strPfad, 1) "\" Then strPfad = strPfad & "\"
If Dir(strPfad & strDatei) "" Then
'alte Wappen löschen
On Error Resume Next
wksTabelle.Shapes.Range(Array("Grafik" & lngSpalte & lngZeile)).Delete
Set rng = wksTabelle.Range(wksTabelle.Cells(lngZeile, lngSpalte), wksTabelle.Cells( _
lngZeile, lngSpalte))
Set shpNeu = wksTabelle.Pictures.Insert(strPfad & strDatei) 'evtl noch Abfrage ob _
Datei überhaupt vorhanden
shpNeu.Top = wksTabelle.Rows(lngZeile).Top
With shpNeu
With .ShapeRange
.LockAspectRatio = msoTrue
If .Height > rng.Height Then .Height = rng.Height
If .Width > rng.Width * iFaktor Then .Width = rng.Width * iFaktor
End With
'.Height = wksTabelle.Rows(lngZeile).Height
'.Left = wksTabelle.Columns(lngSpalte).Left
.Name = "Grafik" & lngSpalte & lngZeile
.Top = rng.Top + (rng.Height - .Height) / 2
.Left = rng.Left + (rng.Width * iFaktor - .Width) / 2
End With
Else
MsgBox strPfad & strDatei & " nicht vorhanden"
End If
Set wksTabelle = Nothing
End Function
Da kannst du zeile und spalte angeben wo das Bild hin soll. zusätzlich noch den Bildnamen (Dateinamen) und optional noch den Pfad, wenn es woanders liegt als die Atbeitsmappe.
du kannst in der Zelle wo es stattfinden soll =GraphicfileInZelleEinfuegen mit den gewünschten Parametern aufrufen oder aber aus VBA heraus.
Sollte weiterhelfen
Gruß
yummi