Bild auswählen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim sFileToOpen As Variant Dim ix As Integer If Target.Address "$E$15" Then Exit Sub On Error GoTo exitImport sFileToOpen = Application.GetOpenFilename("Bilddatei (*.*), *.*", , "Bild importieren") If sFileToOpen False Then ActiveSheet.Pictures.Insert(sFileToOpen).Select If Selection.Height > ActiveCell.Height Or _ Selection.Width > ActiveCell.Width Then Selection.Width = ActiveCell.Width Selection.Height = ActiveCell.Height Else Selection.Top = ActiveCell.Top + ((ActiveCell.Height - Selection.Height) / 2) Selection.Left = ActiveCell.Left + ((ActiveCell.Width - Selection.Width) / 2) End If End If exitImport: Application.CutCopyMode = False ActiveCell.Activate Cancel = True End Sub

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

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread