Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1160to1164
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Probleme mit

Probleme mit
themaker
Guten Abend,
ich hoffe, dass mir hier jemand weiterhelfen kann.
Ich habe ein Problem.
Ich lese mit folgendem Code Grafiken von C:\ aus:
=WENN(U16=50;grafik(C146;"C:\S2F.jpg");"");WENN(U16=60;grafik(C146;"C:\S1F.jpg");"")
Diese Grafik soll dann, wenn eine andere Grafik ausgelesen wird wieder gelöscht werden, usw.
Als Code zum Löschen verwende ich in VBA folgendes:

Private Sub prcTimer(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
On Error Resume Next
Call prcStopTimer
ActiveSheet.Pictures.Delete
Call Grafik_einfuegen
End Sub

Klapp auch super. Dumm nur, dass ich noch zwei Logos und weitere drei erklärende Grafiken
in der Tabelle habe, der er mir dann alle löscht und nur die Graifk im Feld C146 stehen lässt.
Ich dachte zwar, ich könnte es so lösen, dass auch die Logos mit
=WENN(U2=1;grafik(O6;"C:\GLOGO.jpg");"")
ausgelesen werden, wobei U2 ein Feld mit dem festen Wert 1 ist.
Funktioniert auch ganz gut. Leider nur in der Zelle O6. Weiter unten
in der Tabelle klappt dieser Code nicht mehr.
Ich denke, dass man das ganze ggf. mit einem Range-Ansatz lösen kann,
nur leider funktioniert es nicht.
Über Tipps, Tricks und eine Lösung würde ich mich sehr freuen.
Vielen Dank!
LG
themaker

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Probleme mit
21.06.2010 19:18:40
Tino
Hallo,
kenne Deine Code nicht und auch nicht Deine Tabelle und was genau ablaufen soll.
Du kannst aber bei einem Bild feststellen in welcher Zelle die ober linke Ecke sich befindet.
Sub Loesche_Bild()
Dim oPicture As Object
For Each oPic In Tabelle1.DrawingObjects
If TypeName(oPicture) = "Picture" Then
If oPicture.TopLeftCell.Address = Range("C146").Address Then
oPicture.Delete
End If
End If
Next oPic
End Sub
Gruß Tino
AW: Probleme mit
22.06.2010 11:24:26
themaker
Hallo Tino,
vielen Dank für den Ansatz.
Funktioniert leider nicht. Er löscht mir noch immer alle Grafik-Objekte aus der Tabelle und
nicht nur die Grafik, deren linke, obere Ecke in "C146" liegt.
Nachfolgend der komplette VBA-Code. Wo liegt denn da der Fehler?
Option Explicit
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"
Private objCell As Range
Private strPicturePath As String
Private hWnd As Long
Public Function Grafik(Zelle As Range, Pfad As String) As String
Set objCell = Zelle.Cells(1, 1)
strPicturePath = Pfad
hWnd = FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption)
SetTimer hWnd, 0, 1, AddressOf prcTimer
End Function

Private Sub Grafik_einfuegen()
Dim objShape As Picture
Set objShape = ActiveSheet.Pictures.Insert(strPicturePath)
With objShape
.Top = objCell.Top
.Left = objCell.Left
End With
End Sub

Private Sub prcStopTimer()
KillTimer hWnd, 0
End Sub
Sub Loesche_Bild()
Dim oPicture As Object
For Each oPic In Tabelle1.DrawingObjects
If TypeName(oPicture) = "Picture" Then
If oPicture.TopLeftCell.Address = Range("C146").Address Then
oPicture.Delete
End If
End If
Next oPic
End Sub
Private Sub prcTimer(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
On Error Resume Next
Call prcStopTimer
Call Grafik_einfuegen
Call Loesche_Bild
End Sub
Vielen Dank!
LG
Thomas
Anzeige
nicht getestet...
22.06.2010 15:39:28
Tino
Hallo,
, ich würde Loesche_Bild vor Grafik_einfuegen setzen.
In der Sub Loesche_Bild würde ich Range("C146") durch objCell tauschen.
Ich denke aber auch, dass der Code nicht optimal laufen wird.
Wenn mehrere Zellen mit dieser Funktion verarbeitet werden müssen,
wird es nicht sauber laufen.
Gruß Tino
vieleicht würde ich es so umsetzen.
22.06.2010 19:59:22
Tino
Hallo,
kannst ja mal testen.
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


Private objCell() As Range
Private strPicturePath() As String
Private nCount As Long, LEvent As Long

Public Function Grafik(Zelle As Range, Pfad As String) As String
     Redim Preserve objCell(nCount)
     Redim Preserve strPicturePath(nCount)
     
     Set objCell(nCount) = Zelle.Cells(1, 1)
     strPicturePath(nCount) = Pfad
     nCount = nCount + 1

     LEvent = SetTimer(0, 0, 2000, AddressOf BilderEinfuegen)
 End Function


Private Sub Grafik_einfuegen(rngZelle As Range, strPath$)
Dim objShape As Picture
     Set objShape = ActiveSheet.Pictures.Insert(strPath$)
     With objShape
         .Top = rngZelle.Top
         .Left = rngZelle.Left
     End With
 End Sub

Sub Loesche_Bild(rngZelle As Range)
Dim oPicture As Object

For Each oPicture In Sheets(rngZelle.Parent.Name).DrawingObjects
    If TypeName(oPicture) = "Picture" Then
        If oPicture.TopLeftCell.Address = rngZelle.Address Then
            oPicture.Delete
            Exit For
        End If
    End If
Next oPicture

End Sub

Private Sub BilderEinfuegen()
On Error Resume Next
Dim n&

KillTimer 0, LEvent

If nCount = 0 Then Exit Sub

n = Lbound(objCell)

Do While n <= Ubound(objCell)
    Call Loesche_Bild(objCell(n))
    Call Grafik_einfuegen(objCell(n), strPicturePath(n))
    Sleep 50: DoEvents
    n = n + 1
Loop
 
LEvent = 0
nCount = 0
Erase objCell
Erase strPicturePath
End Sub
Besser wäre es aber nicht über eine Formel zu lösen,
ich würde ein Event einbauen, dass auf bestimmten Inhalt reagiert.
Gruß Tino
Anzeige
AW: vieleicht würde ich es so umsetzen.
23.06.2010 09:39:50
themaker
Guten Morgen Tino und nochmal Danke für Deine Ideen.
Ich habe beide gerade mal kurz getestet und es funktioniert leider nicht -seufz-
Hätte ich nicht diese blöden Logos innerhalb der Tabelle wäre alles schön.
Könnte es ggf. über eine Funktion gelöst werden, den den anderen Grafiken
in der Tabelle zugewiesen wird, sodass Excel denkt die Grafik wäre ein Baum
und das ganze nicht löscht?
Kompliziert, kompliziert...
Ich werde versuchen heute im Laufe des Tages mal eine Testdatei zu posten,
die mein Problem veranschaulicht.
Bis dahin freue ich mich natürlich über weitere Lösungsansätze.
Vielen Dank!
LG
Thomas
Anzeige
AW: hier ein Beispiel als zip Datei.
24.06.2010 16:36:27
themaker
Hallo Tino und vielen Dank!
Echt gut gemacht und auch nachvollziehbar, aber leider löst es mein Problem nicht (grrrrrr).
Ich lade jetzt mal eine ZIP-Datei hoch, damit es verständlicher wird.
Bitte nicht am Aufbau stören, ich habe einfach schnell Felder entfernt, etc.
In Abhängigkeit von den drei Auswahlfeldern errechnen sich in U16 und U18 Werte,
die dann in T45 dazu verwendet werden die entsprechenden Grafiken zu laden.
Wenn in R5 später z.B. ein Logo liegt und - sagen wir mal in der Zeile 12 - noch weitere
kleine, sich nicht ändernde Grafiken, wird dieses immer mitgelöscht.
Mit Deinem Ansatz scheint es zwar zu funktionieren, aber leider nicht wenn ich das
Anzeigen an einen bestimmen Wert in einer Zelle (z.B. 1) knüpfe.
Selbst wenn er mir die "1" in der Zelle anzeigt, zeigt er das Logo nicht.
Gebe ich die "1" manuell ein und bestätige mit ENTER, dann klappt es.
Ich hoffe, dass die Datei weiterhilft und bedanke mich für Deine grandiosen
Lösungen bisher, die mir leider - nicht Deine Schuld - nicht weitgeholfen haben.
Wahrscheinlich bin ich einfach nur ein bisschen zu doof dafür!?
Vielen Dank!
LG
themaker
https://www.herber.de/bbs/user/70259.zip
Anzeige
AW: hier ein Beispiel als zip Datei.
24.06.2010 18:49:43
Tino
Hallo,
mach es doch nicht über eine Formel, sondern wie im Beispiel von mir für jede Grafik eine.
Um dies von einem Wert abhängig zu machen, könnte man so machen.
https://www.herber.de/bbs/user/70261.zip
Sonst weiß ich nicht was Du vor hast und kann nicht weiterhelfen. sorry
Gruß Tino
AW: Probleme mit
22.06.2010 11:25:44
themaker
Hallo Tino,
vielen Dank für den Ansatz.
Funktioniert leider nicht. Er löscht mir noch immer alle Grafik-Objekte aus der Tabelle und
nicht nur die Grafik, deren linke, obere Ecke in "C146" liegt.
Nachfolgend der komplette VBA-Code. Wo liegt denn da der Fehler?
Option Explicit
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Const GC_CLASSNAMEMSEXCEL = "XLMAIN"
Private objCell As Range
Private strPicturePath As String
Private hWnd As Long
Public Function Grafik(Zelle As Range, Pfad As String) As String
Set objCell = Zelle.Cells(1, 1)
strPicturePath = Pfad
hWnd = FindWindow(GC_CLASSNAMEMSEXCEL, Application.Caption)
SetTimer hWnd, 0, 1, AddressOf prcTimer
End Function

Private Sub Grafik_einfuegen()
Dim objShape As Picture
Set objShape = ActiveSheet.Pictures.Insert(strPicturePath)
With objShape
.Top = objCell.Top
.Left = objCell.Left
End With
End Sub

Private Sub prcStopTimer()
KillTimer hWnd, 0
End Sub
Sub Loesche_Bild()
Dim oPicture As Object
For Each oPic In Tabelle1.DrawingObjects
If TypeName(oPicture) = "Picture" Then
If oPicture.TopLeftCell.Address = Range("C146").Address Then
oPicture.Delete
End If
End If
Next oPic
End Sub
Private Sub prcTimer(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
On Error Resume Next
Call prcStopTimer
Call Grafik_einfuegen
Call Loesche_Bild
End Sub
Vielen Dank!
LG
Thomas
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige