AW: Bild auswählen
12.09.2007 14:42:00
fcs
Hallo Sven,
solch eine Funktion via Mausklick bzw. Mausdown sollte man nur für einen bestimmten Zellbereich auslösen und nicht für beliebige Zellen im Blatt. In meinem Beispielcode ist es Spalte 3.
Die Prozedur für das Selection_Change-Ereignis im VBA-Editor unter der Tabelle einfügen.
Die Prozedur GrafikEinfuegen fuegst du besser in ein allgemeines Modul der Datei ein, speziell, wenn du die Funktion in mehreren Blättern der Datei nutzen möchtest.
Gruß
Franz
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count = 1 Then
Call BildEinfuegen(Target)
End If
End Sub
Sub BildEinfuegen(Zelle As Range)
' Fügt gewählte Grafik-Datei als Bild in Zelle ein und passt Bild-Größe an Zellgröße an
Dim strDatei, Element As Shape, Faktor As Double
Dim PfadAktiv$, PfadBilder$, DateiFilter$
On Error GoTo Fehler
PfadAktiv = VBA.CurDir
PfadBilder = "C:\Dokumente und Einstellungen\S014123\Eigene Dateien\Eigene Bilder"
VBA.ChDir (PfadBilder)
'Grafikdatei auswählen
DateiFilter = "*.emf; *.wmf; *.jpg; *.jpeg; *.jfif; *.jpe; *.png;" _
& " *.bmp; *.gif; *.tif; *.tiff; *.cdr; *.eps; *.pct; *.pict; *.wpg"
DateiFilter = "Grafikdateien(" & DateiFilter & "), " & DateiFilter
strDatei = Application.GetOpenFilename(Filefilter:=DateiFilter)
If strDatei = False Then Exit Sub
'Grafikdatei einfügen
ActiveSheet.Pictures.Insert(strDatei).Select
Set Element = ActiveSheet.Shapes(Selection.Name)
'Bild größe an Zelle anpassen und Zentrieren
Faktor = Application.WorksheetFunction.Min(Zelle.Height / Element.Height, _
Zelle.Width / Element.Width)
Element.ScaleWidth Faktor, msoFalse, msoScaleFromTopLeft
Element.ScaleHeight Faktor, msoFalse, msoScaleFromTopLeft
Element.Top = Zelle.Top + (Zelle.Height - Element.Height) / 2
Element.Left = Zelle.Left + (Zelle.Width - Element.Width) / 2
VBA.ChDir (PfadAktiv)
Exit Sub
Fehler:
MsgBox "Fehler Nr.: " & Err.Number & " ist aufgetreten" & vbLf & vbLf & _
Err.Description & vbLf & vbLf & _
"Bitte nur Grafik-Datei zum Einfügen auswählen"
End Sub