zellgroße an bildgröße anpassen
Karel
ist es möglich das wenn ein bild in Spalte A eigefügt wird diese Zelle sich automatisch anpasst an der vorgebenen bildgröße " With ActiveSheet.Shapes.AddPicture(StBild, True, True, RaZelle.Offset(0, -1).Left, _
RaZelle.Offset(0, -1).Top, 140, 140)" ?
Wenn kein bild dann zelle wieder auf normale größe zurücksetzen.
In spalte B sind immer wieder unterschiedliche bildnamen erhalten.
Option Explicit ' Variablendefinition erforderlich
Const StPfad As String = "c:\picture\" 'Konstante für Ablagepfad Bilder
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'* H. Ziplies *
'* 24.11.2007 *
'* erstellt von HajoZiplies@web.de *
'* http://Hajo-Excel.de/
Dim StBild As String ' Variable für Bildname
Dim InI As Integer ' Schleifenvariable
Dim RaBereich As Range ' Bereich der Wirksamtkeit
Dim RaZelle As Range ' Zelle die in der _
Schleife bearbeitet wird
' Bereich der Wirksamkeit
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = ("B4:B100") Then Exit Sub
Set RaBereich = Range("B4:B100")
Set RaBereich = Intersect(RaBereich, Range(Target.Address)) ' nur die Zellen Prüfen _
die im überwachten Bereich liegen
If Not RaBereich Is Nothing Then 'falls nicht gefunden _
wird sub verlassen
For Each RaZelle In RaBereich ' Schleife über alle _
veränderten Zellen im überwachten Bereich
Application.EnableEvents = False ' Reaktion auf Eingabe _
abschalten
' Text "kein Bild" löschen
RaZelle.Offset(0, -1) = ""
Application.EnableEvents = True ' Reaktion auf Eingabe _
einschalten
StBild = "Bild " & RaZelle.Address(False, False) ' Bildname erstellen
' altes Bild löschen von jinx
For InI = ActiveSheet.Shapes.Count To 1 Step -1
If ActiveSheet.Shapes(InI).Name = StBild Then
ActiveSheet.Shapes(InI).Delete
Exit For
End If
Next
If RaZelle.Value "" Then ' es wurde ein _
Dateiname eingegeben
' Bildname
'StBild = StPfad & "D" & Format(RaZelle.Value, "00000") & ".jpg"
StBild = StPfad & "" & Format(RaZelle.Value, "") & ".JPG"
'StBild = StPfad & "" & Format(RaZelle.Value) & ""
If Dir(StBild) = "" Then ' Prüfen ob Datei _
vorhanden
Application.EnableEvents = False ' Reaktion auf Eingabe _
abschalten
Target.Offset(0, -1) = "SORRY NO PICTURE"
Application.EnableEvents = True ' Reaktion auf Eingabe _
einschhalten
Else
' einfügen ohne select von Bert Körn
' Ausdruck.AddPicture(FileName, Verknüpfung, in Mappe speichern,
' Pos. Links, Pos. Oben, Breite, Höhe)
' von Klausimausi64 Bildname
' erstes Offset Pos. Links 0 Zeilen und eine Spalte nach rechts
' zweites Offset Pos. Oben 0 Zeilen tiefer und 0 Spalten nach rechts
With ActiveSheet.Shapes.AddPicture(StBild, True, True, RaZelle.Offset(0, -1) _
.Left, _
RaZelle.Offset(0, -1).Top, 140, 140)
sngHoehe = .Height 'Bildhöhe an Variable übergeben _
Hinweis von Uwe (:o)
.OnAction = "Bild_BeiKlick" ' Makro im Modul BeiKlick
.Name = "Bild " & RaZelle.Address(False, False) ' Bildname festlegen
End With
End If
End If
Next RaZelle
End If
Set RaBereich = Nothing ' Variable leeren
End Sub
Grusse
Karel