Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Grafik automatisch in Kommentar einfügen (vom 23.03.2006)





Frage

Hallo Allerseits, ich habe ausoben genannten Beitrag eine sehr gute Lösung für mein Problem gefunden. Mein Code sieht wie folgt aus: Private Sub Worksheet_Change(ByVal Target As Excel.Range) Select Case Target.Value Case "ausgestellt" ActiveCell.AddComment ActiveCell.Comment.Visible = False ActiveCell.Comment.Text Text:="" & Chr(10) & "" ActiveCell.Comment.Shape.Height = 623.25 ActiveCell.Comment.Shape.Width = 425.25 ActiveCell.Comment.Shape.Fill.UserPicture _ "V:\......." & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg" End Select Die Bildnummer wird in aktiver Zeile bei Spalte A herausgesucht. Klappt soweit alles wunderbar. Jetzt habe ich nur ein Problem: Hat der Benutzer aber vorher vergessen, die Bilddatei zu erstellen (Dateiname ist die aktuelle Vorgangsnummer also z.B. "764.jpg") wird trotzdem ein Kommentar erstellt, welches natürlich leer ist. Diesen Fehler würde ich gerne durch eine Prüfung, ob die Bilddatei im Verzeichnis vorhanden ist, umgehen und dann einen Hinweis ausgeben. Leider weiß ich nicht, wie die Überprüfung des Kommentares geschrieben werden muß, ob ein Bild darin enthalten ist oder ob man im Verzeichnis überprüft, ob eine Bildatei mit der aktuellen Vorgangsnummer abgespeichert wurde. Könnt Ihr mir helfen ?? Danke und Gruß Thomas

Antwort 1 von nighty

hi thomas :-)

ein kleines beispiel,duerfte klarheit schaffen :-)

noch kurzbeschreibung

aus der activen zelle wird der dateinamen gelesen

wenn datei vorhanden ist wird das kommentarfeld der activen zelle mit dem bild befuellt

gruss nighty

Sub test()
On Error GoTo fehler
Dim Bpfad As String
Dim Bbild As String
Dim mywidth As Long
Dim myheight As Long
Bbild = ".jpg"
Bpfad = "D:\Briefe\micha\jpg\"
With Application.FileSearch
.NewSearch
.LookIn = Bpfad
.SearchSubFolders = False
.Filename = Cells(ActiveCell.Row, ActiveCell.Column) & Bbild
If .Execute() > 0 Then
ActiveSheet.Pictures.Insert(Bpfad & Cells(ActiveCell.Row, ActiveCell.Column) & Bbild).Select
mywidth = Selection.Width
myheight = Selection.Height
Selection.Delete
Cells(ActiveCell.Row, ActiveCell.Column).AddComment
Application.DisplayCommentIndicator = xlCommentAndIndicator
Cells(ActiveCell.Row, ActiveCell.Column).Comment.Shape.Select True
With Selection.ShapeRange
.Width = mywidth
.Height = myheight
End With
Selection.ShapeRange.Fill.UserPicture Bpfad & Cells(ActiveCell.Row, ActiveCell.Column) & Bbild
Application.DisplayCommentIndicator = xlCommentIndicatorOnly
Cells(ActiveCell.Row, ActiveCell.Column).Comment.Visible = False
End If
End With
End
fehler:
If Err = 1004 Then Resume Next
End Sub


Antwort 2 von nighty

hi thomas :-)

der hinweis koennte ueber eine msgbox erfolgen

gruss nighty

Antwort 3 von XDuckX-Fan

Hi nighty,

danke für deine schnelle Antwort.

Ist dein Code jetzt nur die Überprüfung oder stellt er die gesammte Prozedur mit " Grafik automatisch in Kommentar einfügen" dar, in der dann automatisch die Überprüfung erfolgt und ich somit meinen Code nicht mehr benutzen kann / brauch

Gruß
Thomas

Antwort 4 von XDuckX-Fan

Hallo nighty,

leider funktioniert dein Code nicht, es wird kein Kommentar mit Bild eingefügt. Habe versucht, deinen Code anzupassen, jedoch ohne Erfolg.

Hier mal eine etwas genauere Beschreibung:

Der Kommentar soll in Spalte AS ab Zeile 3 erstellt werden, dazu muß in der Zelle per Dropdown das Wort "ausgestellt" ausgewählt werden.
Nur wenn :

Select Case Target.Value
Case "ausgestellt"

erfüllt ist, soll der Kommentar mit Bild in der aktiven Zelle erstellt werden, wie schon oben lt. Code beschrieben:

ActiveCell.AddComment
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Text Text:="" & Chr(10) & ""
ActiveCell.Comment.Shape.Height = 623.25
ActiveCell.Comment.Shape.Width = 425.25
ActiveCell.Comment.Shape.Fill.UserPicture _
"V:\......." & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg"

Die Bild-ID wird in der aktiven Zeile aus Spalte A herausgesucht und im vorgegebenen Verzeichnis "V:\.....\..." /& Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg" herausgesucht.
Sollte die Bild-ID im vorgegebenen Verzeichnis nicht vorhanden sein, soll ein Hinweis durch eine Msgbox (wie du ja selbst schon vorgeschlagen hast) erscheinen.
Bei genau dieser Routine ActiveCell.Comment.Shape.Fill.UserPicture _
"V:\......." & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg"
würde ich gerne auf z.B. On Error GoTo Fehler2 verweisen.
Fehler2 soll dann lauten:

Fehler2:
Selection.ClearContents
Selection.ClearComments
MsgBox "Fehler blablablabla Fehler"
End

Gibt es keine Möglichkeit, die ActiveCell.Comment.Shape.Fill.UserPicture... - Anweisung zu überprüfen, ob ein Bild im Kommentar geladen wurde, oder vorher zu überprüfen, ob die ausgewählte Bild-ID durch
"V:\......." & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg" überhaupt vorhanden ist und wenn nicht, dann auf Fehler2 verweisen??
Hab schon einiges ausprobiert, aber irgendwie will es nicht klappen.
Währe Dir / Euch sehr dankbar, wenn Ihr dafür eine Lösung habt.

Gruß
Thomas

Antwort 5 von Beverly

Hi Thomas,

ob eine Datei vorhanden ist, kannst du mit diesem Prinzip-Cpde überprüfen

Sub datei_vorhanden()
    Dim fsObject
    Set fsObject = CreateObject("Scripting.FileSystemObject")
    If fsObject.fileexists("C:\Excel_Test\hintergrund.jpg") Then MsgBox "Datei vorhanden"
End Sub


Bis später,
Karin

Antwort 6 von XDuckX-Fan

Hallo Karin,
ich danke dir für deine Hilfe.
Hier der komplette Code für die autom. Kommentarerstellung:

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

Select Case Target.Value

Case "ausgestellt"

ActiveCell.ClearComments
ActiveCell.AddComment
ActiveCell.Comment.Visible = False
ActiveCell.Comment.Text Text:="" & Chr(10) & ""
ActiveCell.Comment.Shape.Height = 623.25
ActiveCell.Comment.Shape.Width = 425.25
ActiveCell.Comment.Shape.Fill.UserPicture _
"V:\....\" & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg"

End Select

Ich habe dabei nur ein Problem:
Wie binde ich deinen Code in meinen ein, um a: eine vorherige oder zeitgleiche Überprüfung durchzuführen, wenn, wie in meinem oben aufgeführten Code die Bilddatei in den Kommentar geladen wird mit: ActiveCell.Comment.Shape.Fill.UserPicture _
"V:\....\" & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg"
, und b: ohne eine Fehlermeldung zu erhalten, denn wenn ich zwischen Case "ausgestellt" und End Select eine IF-Anweisung einfüge, erhalte ich die Fehlermeldung: End Select ohne Select Case.
Das der Code von nighty nicht funktioniert, liegt mit Sicherheit auch nur daran, daß er von mir falsch angepasst wurde, sooo gut kenne ich mich mit VB nun auch nicht aus, bisher hat's jedoch immer gereicht.

Wenn keine entsprechende Bildatei im Verzeichnis vorhanden ist, wird mir ein leerer Kommentar erstellt, muß dann halt damit leben, falls zwischen Select Case... und End Select keine Überprüfung möglich ist oder der Kommentar in der aktiven Zelle nicht überprüft werden kann, ob ein Bild darin vorhanden ist oder nicht.
Vielleicht hat ja doch noch jemand 'ne Idee, ansonsten erst mal Danke an Alle, die sich damit befasst haben. :-)

Gruß
Thomas

Antwort 7 von Beverly

Hi Thomas,

die Prüfung schiebst du zwischen die 1. und 2. Zeile deines Codes

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim fsObject
Set fsObject = CreateObject("Scripting.FileSystemObject")
If Not fsObject.fileexists("C:\Excel_Test\" & Range(Cells(Target.Row, 1), Cells(Target.Row, 1)).Value & ".jpg") Then
    MsgBox "Datei nicht vorhanden"
    Exit Sub
End If
Select Case Target.Value
Case "ausgestellt"
....


Bis später,
Karin

Antwort 8 von XDuckX-Fan

Hi Karin,

Klasse, funktioniert soweit wunderbar. Gibt es noch die die Möglichkeit, deine Überprüfung nur auf Spalte AS auszuführen, wie z.B.
If Target.Address("$AS$3:$AS$30000") = "ausgestellt" Then ... dann dein Code, da ich die MsgBox-Meldung auch auf anderen Spalten erhalte.

danke schon mal im vorraus für alles.

Gruß
Thomas

Antwort 9 von Beverly

Hi Thomas,

schreibe nach der Zeile Dim fsObject foldende 2 Zeilen

If Intersect(Target, Range("AS3:AS30000")) Is Nothing Then Exit Sub
If Target.Count > 1 Then Exit Sub


Bis später,
Karin

Antwort 10 von XDuckX-Fan

Hi Karin,

SUUUPER, funktioniert jetzt alles wunderbar.
Ich danke dir und auch allen anderen, die sich damit beschäftigt haben.
Vielleicht hört man sich ja beim nächsten Problem wieder :-)
Bis dahin....
wünsche ein schönes Wochenende

Gruß
Thomas