Die besonder Fortschrittanzeige

[Anita_290e35]

Hallo,

hoffe dass ich hier richtig bin - VBA6 Excel.

also ich versuche schon seit 2-3 wochen eine fortschrittanzeige zu realisieren in excel vba 6 ( excel 2002)

die f-anzeige sollte funktionieren wie die anzeige an den boxen eines gefrierschranks (der inhalt der box wird per schieber eingestellt)

bisher habe ich es versucht mit einer bildlaufleiste, weil die von der optik und den funktionen schon fast alles mitbringt, nur hätte ich gerne einen grünen balken der links vom schieber den fülltstand anzeigt.

grobe optik: 0-----|------100

Funktion:

• der füllstand wird per hand eingegeben (entweder über den schieber oder über einen wert)
• der wert muss gespeichert werden um beim nächsten aufruf der datei wieder den wert anzuzeigen
• die ganze anzeige muss über einen button kopierbar (vervielfältigbar sein)da die anzahl der einträge in der datei und somit die einzelnen füllungen der einträge unterschiedlich sein können.
  -eine grafische lösung (wie oben beschrieben) wäre echt sehr schön
• die kopie( in einer objektorientierten sprache würde ich sagen es wird eine neue instanz des objekts erstellt)

ich hoffe das mir hier jemand weiterhelfen kann.
weil ich das ding sehr dringend brauche - und selber bisher kläglich gescheitert bin.

erst mal danke und mal sehen ob es überhaupt machbar ist.

gruss anita

[Reinhard_fb8cb7]

Hi Anita,

hoffe dass ich hier richtig bin - VBA6 Excel.

meinst du VB6? zu Excel-VBA steht unten im Anhang etwas.

also ich versuche schon seit 2-3 wochen eine
fortschrittanzeige zu realisieren in excel vba 6 ( excel 2002)
die f-anzeige sollte funktionieren wie die anzeige an den
boxen eines gefrierschranks (der inhalt der box wird per
schieber eingestellt)

Sorry, habe keinen Gefrierschrank, dachte Temperatur kann man einstellen, aber egal, irgendein Füllstand halt.

bisher habe ich es versucht mit einer bildlaufleiste, weil die
von der optik und den funktionen schon fast alles mitbringt,
nur hätte ich gerne einen grünen balken der links vom schieber
den fülltstand anzeigt.

Aus welcher Symbolleiste stammt die Bildlaufleiste?

grobe optik: 0-----|------100
Funktion:

• der füllstand wird per hand eingegeben (entweder über den
  schieber oder über einen wert)
• der wert muss gespeichert werden um beim nächsten aufruf der
  datei wieder den wert anzuzeigen

In einer Zelle, in einer Variablen speichern?

• die ganze anzeige muss über einen button kopierbar

Wie bei der Laufleiste woher stammt der Button?

• die kopie( in einer objektorientierten sprache würde ich
  sagen es wird eine neue instanz des objekts erstellt)

Und, wie gehts weiter mit der Kopie *g?

Gruß
Reinhard
Excel-Versionen

* Excel 2003
Die derzeit letzte Version
Keine gravierenden Änderungen zur Vorgängerversion

* 10.0 (Office XP)
Keine gravierenden Änderungen zur Vorgängerversion

* 9.0 (Office 2000)
Keine gravierenden Änderungen zur Vorgängerversion, dennoch ist nicht jeder Code älterer Versionen lauffähig

* 8.0 (Office 97)
Gravierende Änderungen zur Vorgängerversion
Wegfall des deutschsprachigen VBA, Einführung des VB-Editors und der UserForms mit den MS-Forms2-Steuerelementen

* 7.0 (Office 95)
Keine gravierenden Änderungen zur Vorgängerversion, außer der Umstellung von einer 16-Bit- auf eine 32-Bit-Anwendung.

* 5.0
Gravierenden Änderungen zur Vorgängerversion
Einführung von VBA, damals mit länderspezifischen Sprachelementen

* 4.0
Noch ohne VBA, mit der XL4-Makrosprache

[Chewpapa_22ca98]

Hallo anita,

mit dem Schieber und dem Füllstand habe ich auch etwas noch nicht verstanden. Soll der grüne Balken von links immer bis an den Schieber reichen, oder sind das zwei Werte, ‚soll‘ und ‚ist‘. Wie stellst Du Dir den Schieber vor? Als ein Button? Etwa halb so breit wie hoch o.ä. Rund wie beim neuen Mediaplayer, Mit Spitze oben oder unten wie der ‚Slider‘ in VB6? Mit Skala über oder (und) unter dem Balken?

Mal doch mal, wie das Ding aussehen soll mit Paint, mail mir das Ding, ich versuche mich an einem OCX, wenn ich das fertig habe maile ich es Reinhard und der baut Dir ein Beispiel in VBA damit.

Gruß, Rainer

[Obelix]

Hallo,

grobe optik: 0-----|------100

Versuch es mal mit dem Microsoft Slider Control, das kommt von der Optik schon ziemlich hin. Wenn du dann noch recht und links ein Label anbrings und das auf der Rechten seite mit dem Sliker aktualisieren läßt, dann sollte das passen.

Gruß
Obelix

[Reinhard_fb8cb7]

upos, Link vergessen
Hi Anita,

hatte doch wa sgebastelt, naja, halt nochma :_)

http://www.badongo.com/pic/323748

Solldas so aussehen?

Gruß
Reinhard

[Anita_290e35]

Hallo Obelix,

auch dir vielen Dank für die schnelle Hilfe - versuchs auf jeden fall, schlieslich will ich ja was lernen.
Bisher war ich mit der Anzeige ziemlich erfolglos.

Gruß Anita

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

[Chewpapa_22ca98]

Hi Obelix,

Versuch es mal mit dem Microsoft Slider Control, das kommt von
der Optik schon ziemlich hin.

wie bekomme ich das in VBA? Meine eigenen OCX lassen sich leicht verwenden. Den Slider habe ich in VBA noch nicht verwenden können. Was habe ich falsch gemacht?

Gruß, Rainer

[Reinhard_fb8cb7]

wie bekomme ich das in VBA? Meine eigenen OCX lassen sich
leicht verwenden. Den Slider habe ich in VBA noch nicht
verwenden können. Was habe ich falsch gemacht?

Moin Rainer,
ich habe XL2000, Zusätzliche Steuerelemente…Auswählen, Aufziehen auf dem Bildschirm.
K.A. warum das bei dir nicht gehen sollte.

http://www.badongo.com/pic/324672

Gruß
Reinhard

[Reinhard_fb8cb7]

Mal doch mal, wie das Ding aussehen soll mit Paint, mail mir
das Ding, ich versuche mich an einem OCX, wenn ich das fertig
habe maile ich es Reinhard und der baut Dir ein Beispiel in
VBA damit.

Hallo Anita, Rainer,
die datei

http://www.badongo.com/file/1594780

hat einen Colorslider von Rainer und eine Schaltfläche, der Schaltfläche ist folgendes Makro zugeordnet:

Option Explicit
Sub tt()
ActiveSheet.Shapes(„ColorSlider1“).Copy
ActiveSheet.Paste
Range(„A1“).Select
End Sub

Gruß
Reinhard

[Reinhard_fb8cb7]

wie bekomme ich das in VBA? Meine eigenen OCX lassen sich
leicht verwenden. Den Slider habe ich in VBA noch nicht
verwenden können. Was habe ich falsch gemacht?

Hallo Rainer,
was mir grade einfällt, habe mal vor langer Zeit alle zusätzlichen Steuerelemente ausprobiert aufs Blatt zu ziehen. naja, so 20-30% funktionierten nicht bzw es tat sich nix sichtbares. Okay, z.B beim Browser Control kam eine weiße Fläche und inzwischen wiß ich dass ich dem mit Navigate erst ne Adresse zuweisen muss. Wäre aber nett von MS wenn das gleich in der weißen Fläche stehen würde für Unbedarfte wie mich.
Leider fand ich bis jetzt nirgends im Inet eine Zusammenstellung was das alles für feine Dinge sind. Nicht immer ist der Name sprechend wie bei Calendar usw.
So eine Übersicht mit Kurzbeschreibung der Anwendung wäre Klasse.
Gruß
Reinhard

[Reinhard_fb8cb7]

Hi Anita,
ich habe erstmalig ein Oxc eingebunden, also dass von Rainer.
Ging easy. Im Editor Extras–Verweise–Durchsuchen, die Ocx-datei finden und markieren, vorher im Suchfenster „ocx-Dateien“ auswählen.
Dann auf „Öffnen“ klicken. Irgendwie kam dann noch ein Fenster mit Registrierung, dies auch bestätigen.

Ungetestet, nachträglich registrieren soll so gehen, Explorer 2mal aufmachen. nebeneinander setzen. In dem deinen die ocx lokalisieren, im anderen irgendwo bei Sytem32 o.ä eine Datei regserv32.exe suchen. Dann die ocx per Maus auf die regserv32.exe rüberziehen. Damit soll danndie ocx registriert sein.
Danach steht das ocx unter zusätzliche Steuerelemente zur Verfügung.

Wie gesagt, nicht getestet, Schreibfehler beim Dateinamen ist möglich.
Gruß
Reinhard

[Chewpapa_22ca98]

Hallo Reinhard,

ich habe XL2000, Zusätzliche Steuerelemente…Auswählen,
Aufziehen auf dem Bildschirm.
K.A. warum das bei dir nicht gehen sollte.

Die Steuerelemente aus VB6 tauchen in der Liste der einfügbaren Projekte nicht auf. Der Slider ist wohl in Common Controls 6.0 enthalten, das wird nicht angezeigt, kann ich in VBA nicht verwenden.

Eventuell liegt das an der Version? Office97 ist ja schon recht alt.
Wenn ihr die alle verwenden könnt, ist es ja gut, ich brauch’s ja nicht. Ich beschäftige mich ja nur wegen der Fragen hier mit VBA.

http://www.badongo.com/pic/324672

Ja, hab’ ich gesehen, sieht gut aus. Der ColorSlider kommt mir so bekannt vor … Deine Seite?

Gruß, Rainer

[Obelix]

Kontextmenü „Toolbox“ -> „Additional Controls“ -> Microsoft Slider Control
Wenn der bei dir nicht existiert, ist vielleicht dein VBA zu alt, ich weiß jetzt nicht ob es den schon bei Office 97 gab (bei 2000, XP und 2003 gibt den jedenfalls)

Gruß
Obelix

[Bei dieser Antwort wurde das Vollzitat nachträglich automatisiert entfernt]

[Reinhard_fb8cb7]

Kontextmenü „Toolbox“ -> „Additional Controls“ ->
Microsoft Slider Control
Wenn der bei dir nicht existiert, ist vielleicht dein VBA zu
alt, ich weiß jetzt nicht ob es den schon bei Office 97 gab
(bei 2000, XP und 2003 gibt den jedenfalls)

Hallo Obelix,
bei XL97 steht er, bzw zwei Slider genauso drin wie bei XL2000, aber beim Eibinden kommt Fehler, „kann Objekt nicht einfügen“ o.ä.

Gruß
Reinhard

[Reinhard_fb8cb7]

Hallo an alle Interessierten,
in guter Zusammenarbeit mit Rainer habe ich nun eine Excel-Datei mit VBA-Code gebastelt.
Vorhandene Bugs sind (noch):
- ab Farbwerte 15 gibt es wohl Probleme (nicht getestet)
- die Schieberneupositionierung des Sliders nach Zellwertänderung hat 
 beschlossen grad mal wieder nicht zu funktieren dabei funktionierte 
 das problemlos in Version 1,2,3 der Datei, also kriege ich das noch hin \*annehm\*
- bei neueingefügten Slidern mittels Button funktioniert der Slider
 nicht, erst wenn man in der Steuerelementtoolbox kurz in 
 Entwurfsmodus geht und wieder raus funktioniert es. 
 Ich nehme an das ist ein Problem der late binding, k.A. wie das zu
 lösen ist. Meine Hoffnung auf eine Lösung ruht auf diesem Forum und/oder einem anderen
 Excelprofiforum.
- Code in DieseArbeitsmappe fehlt derzeit noch damit die Sliderpositionen beim Öffnen noch stimmen

Features:
- Aufgrund einer Anfrage habe ich den Max-Wert von Slider 4 auf
 100.000 gestellt, das geht problemlos, also keine Einschränkung
 auf 32768 wie bei einem "Vscroll" was es wohl in VB gibt \*k.A\*
 (Warum dabei der Min-Wert auf 22 hüpfte bliebe noch zu klären.)

Die Datei: **http://www.badongo.com/file/1640646**  
Das Ocx : **http://www.badongo.com/file/1640650** 
Nachfolgend ist der VBA-Code.

Gruß
Reinhard

Code von **Tabelle2:**

Option Explicit

Private Sub CommandButton1\_Click()
Dim N As Integer, Bez As String, Anz As Integer
Dim Links, Oben, ObenOffset, ObenAbstand, Höhe, Zeilenhöhe, Breite
Links = Columns(9).Left 'Links von I
ObenOffset = 2 ' 2 Zeilen oberer Abstand zum obersten Slider
ObenAbstand = 3 ' Anzahl Zeilen zwischen 2 Slidern
Breite = Columns(13).Left - Columns(9).Left 'Breite von L-K
Zeilenhöhe = Rows(5).Top - Rows(4).Top 'Höhe der Zeile 4
Application.ScreenUpdating = False
With ActiveSheet.OLEObjects
 On Error Resume Next ' weil es kurzzeitig 2 gleichameige Slider geben könnte
 For N = 1 To .Count
 If .Item(N).Name Like "ColorSlider\*" Then
 Anz = Anz + 1
 .Item(N).Name = "ColorSlider" & Anz
 End If
 Next N
 On Error GoTo 0
 Bez = "ColorSlider" & Anz + 1
 Höhe = 2 \* Zeilenhöhe
 If Anz 0 Then
 Oben = .Item("ColorSlider" & Anz).Top + (ObenAbstand + 2) \* Zeilenhöhe
 Else
 Oben = Rows(ObenOffset + 1).Top
 End If
 .Add(ClassType:="ColSlider.ColorSlider", Link:=False, DisplayAsIcon:=False, Left:=Links, Top:=Oben, Height:=Höhe, Width:=Breite).Name = Bez
 .Item(Bez).Object.SetValue 0
 Range(.Item(Bez).TopLeftCell.Offset(0, 4).Address) = 0
 '.Item(Bez).TopLeftCell.Offset(0, 4).Value = .Item(Bez).Value
 '.Item(Bez).Object.TopLeftCell.Offset(0, 4).Value = .Item(Bez).Object.Value
End With
Application.ScreenUpdating = True
Call Test
End Sub



Private Sub Worksheet\_Change(ByVal Target As Range)
If Target.Column 13 Then Exit Sub
If Target.Cells.Count \> 1 Then Exit Sub
'On Error Resume Next 'wenn kein Slider da
'MsgBox Range(ActiveSheet.OLEObjects.Item("ColorSlider" & Int((Target.Row() - 3) / 5) + 1).TopLeftCell).Address
If ActiveSheet.OLEObjects(Int((Target.Row() - 3) / 5) + 1).TopLeftCell = Target.Address Then
 ActiveSheet.OLEObjects(Int((Target.Row() - 3) / 5) + 1).Object.SetValue Target.Value
End If
On Error GoTo 0
End Sub

Private Sub ColorSlider1\_move()
Application.EnableEvents = False
If ColorSlider1.Value \> 100 Then ColorSlider1.Value = 100
If ColorSlider1.Value 100 Then ColorSlider2.Value = 100
If ColorSlider2.Value 100 Then ColorSlider3.Value = 100
If ColorSlider3.Value 100 Then ColorSlider4.Value = 100
'If ColorSlider4.Value Modul2:

Option Explicit

Private Sub CommandButton1\_Click()
Dim N As Integer, Bez As String, Anz As Integer
Dim Links, Oben, ObenOffset, ObenAbstand, Höhe, Zeilenhöhe, Breite
Links = Columns(9).Left 'Links von I
ObenOffset = 2 ' 2 Zeilen oberer Abstand zum obersten Slider
ObenAbstand = 3 ' Anzahl Zeilen zwischen 2 Slidern
Breite = Columns(13).Left - Columns(9).Left 'Breite von L-K
Zeilenhöhe = Rows(5).Top - Rows(4).Top 'Höhe der Zeile 4
Application.ScreenUpdating = False
With ActiveSheet.OLEObjects
 On Error Resume Next ' weil es kurzzeitig 2 gleichameige Slider geben könnte
 For N = 1 To .Count
 If .Item(N).Name Like "ColorSlider\*" Then
 Anz = Anz + 1
 .Item(N).Name = "ColorSlider" & Anz
 End If
 Next N
 On Error GoTo 0
 Bez = "ColorSlider" & Anz + 1
 Höhe = 2 \* Zeilenhöhe
 If Anz 0 Then
 Oben = .Item("ColorSlider" & Anz).Top + (ObenAbstand + 2) \* Zeilenhöhe
 Else
 Oben = Rows(ObenOffset + 1).Top
 End If
 .Add(ClassType:="ColSlider.ColorSlider", Link:=False, DisplayAsIcon:=False, Left:=Links, Top:=Oben, Height:=Höhe, Width:=Breite).Name = Bez
 .Item(Bez).Object.SetValue 0
 Range(.Item(Bez).TopLeftCell.Offset(0, 4).Address) = 0
 '.Item(Bez).TopLeftCell.Offset(0, 4).Value = .Item(Bez).Value
 '.Item(Bez).Object.TopLeftCell.Offset(0, 4).Value = .Item(Bez).Object.Value
End With
Application.ScreenUpdating = True
Call Test
End Sub



Private Sub Worksheet\_Change(ByVal Target As Range)
If Target.Column 13 Then Exit Sub
If Target.Cells.Count \> 1 Then Exit Sub
'On Error Resume Next 'wenn kein Slider da
'MsgBox Range(ActiveSheet.OLEObjects.Item("ColorSlider" & Int((Target.Row() - 3) / 5) + 1).TopLeftCell).Address
If ActiveSheet.OLEObjects(Int((Target.Row() - 3) / 5) + 1).TopLeftCell = Target.Address Then
 ActiveSheet.OLEObjects(Int((Target.Row() - 3) / 5) + 1).Object.SetValue Target.Value
End If
On Error GoTo 0
End Sub

Private Sub ColorSlider1\_move()
Application.EnableEvents = False
If ColorSlider1.Value \> 100 Then ColorSlider1.Value = 100
If ColorSlider1.Value 100 Then ColorSlider2.Value = 100
If ColorSlider2.Value 100 Then ColorSlider3.Value = 100
If ColorSlider3.Value 100 Then ColorSlider4.Value = 100
'If ColorSlider4.Value 

[Reinhard_fb8cb7]

Her ist Modul1
Sorry,
2mal den Code von Tabelle2 gepostet, hier ist der Code von Modul1:

Option Explicit

Sub Fortschrittsanzeige()
 ActiveSheet.OLEObjects.Add(ClassType:="ColSlider.ColorSlider", Link:=False, DisplayAsIcon:=False).Select
End Sub

Sub Erzeugen(ByVal Anzahl As Integer)
Dim N As Integer, Zei As Long
With Worksheets("Tabelle3")
 .Columns(1).Clear
 For N = 1 To Anzahl
 Zei = (N - 1) \* 7 + 1
 .Cells(Zei, 1) = "Private Sub ColorSlider" & N & "\_move()"
 .Cells(Zei, 1).Offset(1, 0) = "Application.EnableEvents=False"
 .Cells(Zei, 1).Offset(2, 0) = "worksheets(" & Chr(34) & "Tabelle1" & Chr(34) & ").cells(" & N + 1 & ",2).Value=ColorSlider" & N & ".value"
 .Cells(Zei, 1).Offset(3, 0) = "Application.EnableEvents=True"
 .Cells(Zei, 1).Offset(4, 0) = "ColorSlider" & N & ".SetValue [B" & N + 1 & "]"
 .Cells(Zei, 1).Offset(5, 0) = "End Sub"
 Next N
 Zei = Anzahl \* 7 + 1
 .Range("A" & Zei) = "Private Sub Worksheet\_Change(ByVal Target As Range)"
 .Range("A" & Zei).Offset(1, 0) = "If Target.Column 2 Then Exit Sub"
 .Range("A" & Zei).Offset(2, 0) = "Dim N as Integer"
 .Range("A" & Zei).Offset(3, 0) = "With ActiveSheet"
 .Range("A" & Zei).Offset(4, 0) = " For N = 1 To Worksheets(" & Chr(34) & "Tabelle3" & Chr(34) & ").Range(" & Chr(34) & "B1" & Chr(34) & ").value"
 For N = 1 To Anzahl
 .Range("A" & Zei).Offset(4 + N, 0) = " ColorSlider" & N & ".SetValue Worksheets(" & Chr(34) & "Tabelle1" & Chr(34) & ").Range(" & Chr(34) & "B" & N + 1 & Chr(34) & ")"
 Next N
 .Range("A" & Zei).Offset(4 + N, 0) = " Next N"
 .Range("A" & Zei).Offset(4 + N + 1, 0) = "End With"
 .Range("A" & Zei).Offset(4 + N + 2, 0) = "End Sub"
 .Range("A1:A" & .Range("A65536").End(xlUp).Row).Copy
End With

End Sub

Sub Slider\_Move\_Code\_Erzeugen()
Call Erzeugen([B1].Value)
End Sub
Sub testX()
ActiveSheet.OLEObjects.Add(ClassType:="ColSlider.ColorSlider", Link:=False, DisplayAsIcon:=False).Select
End Sub

Public Sub Test()
Dim objModul As Object, Zei As Long, Bez As String, N, t As Long, ov, vorh As Boolean
Set objModul = ThisWorkbook.VBProject.VBComponents("Tabelle2")
Zei = objModul.CodeModule.CountofLines
With objModul.CodeModule
 For t = 1 To ActiveSheet.OLEObjects.Count
 Set ov = ActiveSheet.OLEObjects(t)
 If ov.Name Like "ColorSlider\*" Then
 N = N + 1
 End If
 Next t
If N = 0 Then Exit Sub
 Bez = "ColorSlider" & N
 'MsgBox .Lines(3, 1)
 For t = 1 To Zei
 If InStr(.Lines(t, 1), Bez & "\_move()") Then Exit Sub
 Next t
 .InsertLines Zei + 2, "Private Sub " & Bez & "\_move()"
 .InsertLines Zei + 3, "Application.EnableEvents=False"
 .InsertLines Zei + 4, "If " & Bez & ".Value \> 100 Then " & Bez & ".Value = 100"
 .InsertLines Zei + 5, "If " & Bez & ".Value