Bild über VBA in einer Zelle einfügen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc] Sub Bild_einfügen_und_Anpassen_aus_Datei() ' Fügt ein Bild aus einer Datei ein und passt es an ' Eingefügt an selektierter Stelle, Höhe/Breite bleibt Dim sPicFile As Variant, oPic As Shape sPicFile = Application.GetOpenFilename _ ("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.jxr), *.gif; *.jpg; *.bmp; *.tif; *.jxr", _ , "Bild auswählen") If sPicFile <> "" Then Set oPic = ActiveSheet.Shapes.AddPicture(Filename:=sPicFile, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=Selection.Left, Top:=Selection.Top, Width:=-1, Height:=-1) With oPic .LockAspectRatio = msoTrue .Height = .TopLeftCell.Height ' Höhe der Bild-Zelle .Placement = xlMoveAndSize End With Set oPic = Nothing End If End Sub

Code: [Cc][+][-] Sub Bild_Einfuegen_und_Anpassen_aus_Datei2() ' Sub fügt ein Bild in eine Zelle/Bereich ein ' Eingefügt an selektierter Stelle, Höhe/Breite werden angepasst Dim AC As Range, oPic As Object Dim sPicFile As String sPicFile = Application.GetOpenFilename _ ("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.jxr), *.gif; *.jpg; *.bmp; *.tif; *.jxr", _ , "Bild auswählen") ' Bereich setzen, auch verbundene Zellen oder Range Set AC = ActiveCell.MergeArea 'Range("B5:R17") ' Bild einfügen in linke obere Ecke, Originalgröße Set oPic = ActiveSheet.Shapes.AddPicture(sPicFile, _ False, True, AC.Left + 1, AC.Top + 1, -1, -1) If Not oPic Is Nothing Then If oPic.Width > oPic.Height Then ' Querformat oPic.Width = AC.Width - 2 If oPic.Height > AC.Height Then oPic.Height = AC.Height - 2 Else oPic.Height = AC.Height - 2 ' Hochformat If oPic.Width > AC.Width Then oPic.Width = AC.Width - 2 End If Set oPic = Nothing End If End Sub

Guten Morgen Karl-Heinz,
erstmal vielen Dank für deine Arbeit.
Leider verstehe ich das nicht so richtig, bin ein Anfänger bei VBA.:)
Den Link kann ich leider auch nicht abrufen.
Ich hab hier aber im Forum weiter recherchiert und bin auf
"https://www.herber.de/mailing/Bild_bei_Klick_vergroessern_und_zuruecksetzen.htm" gestoßen.
Das wäre sogar die Ideallösung für mich. Leider funktioniert die nicht und ich müsste das Makro bei jedem Bild separat hinzufügen. Wäre das auch möglich in der Kombination mit deinem Code "Bild_einfügen_und_Anpassen_aus_Datei".
Eine weitere Frage ist. Ich will nur in bestimmten Spalten ein Bild in der Zelle einfügen. (Bsp: D:F).
Wäre super, wenn du mir weiterhelgen könntest. :)
Danke
Viele Grüße
Christian

Hallo Christian,
seit einiger Zeit kann man die Links nur noch per Rechtsclick "Im neuen Tab öffnen" aufrufen.
Wenn Du das Vergrößern-Makro nutzen möchtest, brauchst Du das nur einmal in einem normalen Modul vorhalten.
Für jedes gewünschte Bild ordnest Du per Rechtsklick immer das gleiche Makro zu.
Über die Application.Caller Funktion wird das entsprechende Bild erkannt.
Allerdings funktioniert das dort angebene Makro wohl nur, wenn im darunterliegenden Feld Angaben zur Größe gemacht werden.
Hier eine Alternative von mir:

Code:


[Cc]

Sub Grafik_GrossKlein()
' Funktion vergrößert das Bild auf dem Arbeitsbereich
  Dim vArr As Variant
 
  Const Faktor As Single = 1.6                      ' Vergößerungsfaktor
 
  With ActiveSheet.Shapes(Application.Caller)       ' Name der Grafik
  
     If .AlternativeText = "" Then
        .AlternativeText = .Left & ";" & .Top & ";" & .WIDTH & ";" & .HEIGHT
        .ScaleWidth Faktor, msoFalse
        .ScaleHeight Faktor, msoFalse
        .ZOrder msoBringToFront                     ' In den Vordergrund

     Else
        vArr = Split(.AlternativeText, ";")
        .Left = vArr(0):  .Top = vArr(1)            ' Bildposition wiederherstelllen
        .WIDTH = vArr(2): .HEIGHT = vArr(3)
        .AlternativeText = ""
     End If
  End With
End Sub

Bitte bedenken, dass diese Vergrößerungsmakros auf bereits vorhandene Bilder angewendet werden. Eine Kombination mit meinem Erstcode, bei dem ja die Bilder erst ausgesucht und eingefügt werden, ist m.E. nicht sinnvoll.
Und noch mal zu den Einfügemakros. Eine Verzerrung des Bildes erfolgt mit keinem der Makros.
In der ersten Version wird nur auf die Höhe einer Zelle angepasst, die Breite geht evtl. über die Zelle hinaus.
In der zweiten Version wird das Bild auf jeden Fall unverzerrt in das Feld eingepasst.
Du meinst wahrscheinlich, dass bei einer nachträglichen Veränderung der Zeilenhöhe das Bild verzerrt wird. Dazu habe ich keine Kenntnis, ob und wie dann die Breite mit angepasst werden kann.
Viele Grüße
Karl-Heinz

Sub Bild_Einfuegen_und_Anpassen_aus_Datei() ' Sub fügt ein Bild in eine Zelle/Bereich ein ' Eingefügt an selektierter Stelle, Höhe/Breite werden angepasst Dim AC As Range, oPic As Object Dim sPicFile As String sPicFile = Application.GetOpenFilename _ ("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.jxr), *.gif; *.jpg; *.bmp; *.tif; *.jxr", _ , "Bild auswählen") ' Bereich setzen, auch verbundene Zellen oder Range Set AC = ActiveCell.MergeArea 'Range("B5:R17") ' Bild einfügen in linke obere Ecke, Originalgröße Set oPic = ActiveSheet.Shapes.AddPicture(sPicFile, _ False, True, AC.Left + 1, AC.Top + 1, -1, -1) If Not oPic Is Nothing Then If oPic.Width > oPic.Height Then ' Querformat oPic.Width = AC.Width - 2 If oPic.Height > AC.Height Then oPic.Height = AC.Height - 2 Else oPic.Height = AC.Height - 2 ' Hochformat If oPic.Width > AC.Width Then oPic.Width = AC.Width - 2 End If Set oPic = Nothing End If End Sub __________________________________ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("H2:J50")) Is Nothing Then Call _ Bild_Einfuegen_und_Anpassen_aus_Datei End Sub

Code: [Cc][+][-] Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Not Intersect(Target, Range("D2:F10")) Is Nothing Then Call Bild_Einfuegen_und_Anpassen_aus_Datei(Target) Cancel = True End If End Sub Sub Bild_Einfuegen_und_Anpassen_aus_Datei(Target As Range) ' Sub fügt ein Bild in eine Zelle/Bereich ein ' Eingefügt an selektierter Stelle, Höhe/Breite werden angepasst Dim oPic As Object Dim sPicFile As String sPicFile = Application.GetOpenFilename _ ("Pictures (*.gif; *.jpg; *.bmp; *.tif; *.jxr), *.gif; *.jpg; *.bmp; *.tif; *.jxr", _ , "Bild auswählen") If sPicFile = "Falsch" Then Exit Sub ' Bild einfügen in linke obere Ecke, Originalgröße Set oPic = ActiveSheet.Shapes.AddPicture(sPicFile, _ False, True, Target.Left + 1, Target.Top + 1, -1, -1) If Not oPic Is Nothing Then If oPic.Width > oPic.Height Then ' Querformat oPic.Width = Target.Width - 2 If oPic.Height > Target.Height Then oPic.Height = Target.Height - 2 Else oPic.Height = Target.Height - 2 ' Hochformat If oPic.Width > Target.Width Then oPic.Width = Target.Width - 2 End If oPic.Left = Target.Left + 1 oPic.Top = Target.Top + 1 Set oPic = Nothing End If End Sub

Code: [Cc][+][-] Sub ZoomIN_OUT() Dim LNG_COUNTER As Long Dim BOL_ZOOMED As Boolean BOL_ZOOMED = False For LNG_COUNTER = 0 To UBound(ARY_ZOOMED_PIC) If Application.Caller = ARY_ZOOMED_PIC(LNG_COUNTER) Then BOL_ZOOMED = True Exit For End If Next LNG_COUNTER If BOL_ZOOMED = True Then ' //Bildname löschen ARY_ZOOMED_PIC(LNG_COUNTER) = "" ' //ZoomOUT With ActiveSheet.Shapes(Application.Caller) .Height = .Height / LNG_FAKTOR .Width = .Width / LNG_FAKTOR End With Else ' //Bildname merken ReDim Preserve ARY_ZOOMED_PIC(UBound(ARY_ZOOMED_PIC) + 1) ARY_ZOOMED_PIC(UBound(ARY_ZOOMED_PIC)) = Application.Caller ' //ZoomIN With ActiveSheet.Shapes(Application.Caller) .Height = .Height * LNG_FAKTOR .Width = .Width * LNG_FAKTOR .ZOrder msoBringToFront ' In den Vordergrund End With End If End Sub

Beliebteste Forumthreads (12 Monate)

Bild über VBA in einer Zelle einfügen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild über VBA in einer Zelle einfügen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread