AW: Logo einfügen
04.11.2012 20:22:24
Tom
Ich habe versucht, den Code von Deiner Beispieldatei auf Deiner Website abzuändern, aber ich vermute hierfür reichen meine VBA-Kenntnisse nicht aus. Aber ich denke, dass ist genau der Lösungsansatz:
Option Explicit
' Konstante für Ablagepfad Bilder
' Const StPfad As String = "K:\Allgemein\text-Dateien\" ' Bildordner wird nicht benötigt
Dim Loi As Long ' Schleifenvariable
Dim StTabelle As String ' Tabellenname
Dim StAdresse As String ' Zelladresse
Private Sub Workbook_Open()
'* H. Ziplies *
'* 27.01.10 *
'* erstellt von HajoZiplies@web.de *
'* http://Hajo-Excel.de/
' Array mit Adressen und eingetragen Werte füllen
' da Bilder schon eingefügt wurden müssen die nicht eingefügt werden
StArray = Array(Array("", "", "", "", "", ""), Array("Spielplan!E3:E79", "Spielplan!G3:g79", _
"Spielplan!Y3:y79", "Spielplan!AA3:AA79", Spielplan!AS3:AS79"))
For Loi = 0 To UBound(StArray(0), 1)
' Tabelle abtrennen
StTabelle = Application.WorksheetFunction.Substitute(Left(StArray(1)(Loi), InStr( _
StArray(1)(Loi), "!") - 1), "'", "")
StAdresse = Application.WorksheetFunction.Substitute(Mid(StArray(1)(Loi), InStr(StArray( _
1)(Loi), "!") + 1), "'", "")
If Worksheets(StTabelle).Range(StAdresse) "" And InStr(Worksheets(StTabelle).Range( _
StAdresse), ".") > 0 Then StArray(0)(Loi) = Range(StArray(1)(Loi))
Next Loi
End Sub
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
'* H. Ziplies *
'* 27.01.10 *
'* erstellt von HajoZiplies@web.de *
'* http://Hajo-Excel.de/
Dim StBild As String ' Variable für Bildname
Application.ScreenUpdating = False ' _
Bildschimaktualisierung aus
For Loi = 0 To UBound(StArray(0), 1)
StTabelle = Application.WorksheetFunction.Substitute(Left(StArray(1)(Loi), InStr( _
StArray(1)(Loi), "!") - 1), "'", "")
StAdresse = Application.WorksheetFunction.Substitute(Mid(StArray(1)(Loi), InStr(StArray( _
1)(Loi), "!") + 1), "'", "")
If Worksheets(StTabelle).Range(StAdresse) "" And InStr(Worksheets(StTabelle).Range( _
StAdresse), ".") > 0 _
And Worksheets(StTabelle).Range(StAdresse) StArray(0)(Loi) Then
'neues Bild
On Error Resume Next ' falls Bild nicht _
vorhanden
Worksheets(StTabelle).Shapes("Bild " & StArray(1)(Loi)).Delete
On Error GoTo 0 ' Fehlerbehandlung zurü _
ck
StBild = ThisWorkbook.Path & "\" & Worksheets(StTabelle).Range(StAdresse)
If Dir(StBild) = "" Then ' Prüfen ob Datei _
vorhanden
Application.EnableEvents = False ' Reaktion auf Eingabe _
abschalten
Worksheets(StTabelle).Range(StAdresse).Offset(0, 1) = "kein Bild"
StArray(0)(Loi) = "" ' Bildnamen löschen
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 Worksheets(StTabelle).Shapes.AddPicture(StBild, True, True, Worksheets( _
StTabelle).Range(StAdresse).Offset(0, 2).Left, _
Worksheets(StTabelle).Range(StAdresse).Offset(0, 0).Top, 100, 100)
sngHoehe = .Height ' Bildhöhe an Variable ü _
bergeben Hinweis von Uwe (:o)
.OnAction = "Bild_BeiKlick" ' Makro im Modul _
BeiKlick
.Name = "Bild " & StArray(1)(Loi) ' Bildname festlegen
End With
StArray(0)(Loi) = Worksheets(StTabelle).Range(StAdresse) ' neues Bild in _
Array
End If
ElseIf Worksheets(StTabelle).Range(StAdresse) = "" Then
On Error Resume Next ' falls Bild nicht _
vorhanden
Worksheets(StTabelle).Shapes("Bild " & StArray(1)(Loi)).Delete
On Error GoTo 0 ' Fehlerbehandlung zurü _
ck
StArray(0)(Loi) = "" ' Bildnamen löschen
End If
Next Loi
Application.ScreenUpdating = True ' _
Bildschimaktualisierung ein
End Sub