'entwickelt von Winfried Radner
'e-mail: Wolf.W.Radzinski@onlinehome.de
'Benutzung frei - ohne Gewähr
'
'Was macht das Teil?
'Merke dir Zellbereiche irgendeines Arbeitsblattes
'in beliebigen (geöffneten) Arbeitsmappen und springe
'bei Bedarf per Menubuttonklick dorthin zurück.
'
'NOCH NICHT FEHLERFREIE VERSION! siehe
'
'http://www.rendar.de/excel/pos_merker.txt (diese Datei!)
'http://www.rendar.de/excel/pos_merker.bas (Makros!)
'
'
LETZTE VERSION ist unter
'
'http://www.rendar.de/excel/sprungmarken2.xla  bzw
'http://www.rendar.de/excel/sprungmarken2.zip 
'abelegt!!

'Unterschiede zur alten pos_merker.xls?
'1) ein paar Fehler behoben z.B. kein Absturz bei
'   Commandbarnutzung, wenn kein Workbook offen ist!
'2) Einstellungen werden jetzt von Sitzung zu Sitzung
'   übernommen (natürlich nicht die Marken)
'2a) benannte Zellbereiche können jetzt als marken eingelesen werden!
'2b) beannte Bereiche erzeugen RELATIV adressierte Marken!
'3) die XLS Datei einfach in den Ordner XLSTART kopieren und
'   eventuell noch die Symbolleiste sichtbar machen. Fertig!

'Mein Dank gilt ganz besonders Ullrich Schwarz, von dem ein Teil
'des Codes stammt (.onAction mit Parameterübergabe!).
'Außerdem danke ich auch Frank Arendt-Theilen,
'Dr. Eckehard Pfeifer und Bernd Augustin die mich u.a. per Newsgroup
'aus so manchem dunklen Tal geführt haben.
'
'der folgende Code ist alt und nicht fehlerfrei ... reicht aber, um
'die Arbeitsweise darzustellen.

Option Explicit
Public max_Merker, akt_Merker, top_Merker, global_i As Integer
Public n_check, m_change As CommandBarButton
Public pop2, cbu As Object
Const l_butts = 5
Const face_1 = 131 'empty_box
Const face_2 = 2 'abc Häkchen

Const cb_title = "Sprungmarken"
Const cbmark = "SprMark "

Const t_tip1 = "Inputbox [Sprungmarken benennen] einblenden?"
Const t_tip2 = "Inputbox [Sprungmarken benennen] ausblenden?"
Const tt1 = "Sprungmarke speichern"
Const tt2 = "aktuelle Sprungmarke löschen"
Const tt3 = "gehe zur vorherigen Sprungmarke"
Const tt4 = "gehe zur nächsten Sprungmarke"
Const tt5 = "Obergrenze für Sprungmarkenliste"
Const cp1 = "ALLE Sprungmarken löschen"
Const cp2 = "Sprungmarke speichern"
Const cp3 = "Sprungmarke ..."
Const cp31 = "Sprungmarke einfügen...hinter"
Const cp32 = "Sprungmarke einfügen...vor"
Const cp4 = "aktuelle Sprungmarke umbenennen"
Const cp5 = cp1
Const cp6 = "hinter"
Const cp7 = "vor"
Const msg1 = "Es ist ein Fehler beim Erstellen der Symbolleiste aufgetreten"
Const msg2 = "Es wurde kein Zellbereich markiert."
Const msg3 = "Falls die Sprungmarke einen Namen erhalten soll, diesen"
Const msg31 = "bitte hier eintragen."
Const msg4 = "Beim Speichern der Sprungmarke ist ein Fehler aufgetreten"
Const msg5 = "Sprungmarke nicht gefunden."
Const msg51 = "Evtl. ist die Mappe nicht geöffnet oder die Tabelle nicht mehr vorhanden"
Const msg6 = "Änderung fehlgeschlagen!"
Const msg7 = "Beim Versuch eine Marke"
Const msg71 = "in die Sprungliste einzufügen"
Const msg72 = "trat leider ein Fehler auf!"
Const msgi1 = "Ändere die Obergrenze der Sprungzielliste"
Const msgi11 = "(NULL für ENDLOSE Liste!)"
Const msgi2 = "Falls die Sprungmarke einen (anderen) Namen"
Const msgi21 = "erhalten soll, diesen bitte hier eintragen bzw. ändern."
Const msgit = "Obergrenze Sprungliste"
Const tx1 = "einzelne Sprungmarke löschen"



'auf False ändern, wenn man sofort ohne Inputbox bei
'SavePosition starten will
Const start_inputbox_ja = True 'gewünschte Vorbelegung für den Start


Sub ErstelleCb()
Dim cb As Object
On Error GoTo FEHLER
max_Merker = 31
For Each cb In Application.CommandBars
    If cb.Name = cb_title Then cb.Delete
    Next
Set cb = Application.CommandBars.Add(cb_title, Temporary:=True)
cb.Visible = True
With cb.Controls.Add(before:=1, Type:=msoControlButton)
    .Style = msoButtonIcon
    .FaceId = 137 'Pluszeichen
    .TooltipText = tt1
    .OnAction = "SavePosition"
    End With
With cb.Controls.Add(before:=2, Type:=msoControlButton)
    .Style = msoButtonIcon
    .FaceId = 138 'Minuszeichen
    .TooltipText = tt2
    .OnAction = "loesche_akt_marke"
    End With
With cb.Controls.Add(before:=3, Type:=msoControlButton)
    .Style = msoButtonIcon
    .FaceId = 47 'Radiergummi
    .Caption = cp1
    .OnAction = "Reset"
    End With
Set cbu = cb.Controls.Add(Type:=msoControlPopup)
With cbu
    .Caption = cbmark & "0/0"
    .Tag = "gemerkt"
    End With
Set n_check = cb.Controls.Add(before:=5, Type:=msoControlButton)
With n_check
    .Style = msoButtonIcon
    If start_inputbox_ja Then
        .FaceId = face_2
        .Parameter = True
        .TooltipText = t_tip2
        Else
        .FaceId = face_1
        .Parameter = False
        .TooltipText = t_tip1
        End If
    .OnAction = "change_n_check"
    End With
With cb.Controls.Add(before:=6, Type:=msoControlButton)
    .Style = msoButtonIcon
    .FaceId = 132 'Pfeil links
    .TooltipText = tt3
    .OnAction = "springe_minus"
    End With
With cb.Controls.Add(before:=7, Type:=msoControlButton)
    .Style = msoButtonIcon
    .FaceId = 133 'Pfeil rechts
    .TooltipText = tt4
    .OnAction = "springe_plus"
    End With
Set m_change = cb.Controls.Add(before:=8, Type:=msoControlButton)
With m_change
    .Style = msoButtonCaption
    .Caption = CStr(max_Merker)
    .TooltipText = tt5
    .OnAction = "change_merker"
    End With
With cbu.CommandBar.Controls.Add(before:=1, Type:=msoControlButton)
    .Caption = cp2
    .OnAction = "SavePosition"
    End With
Set pop2 = cbu.CommandBar.Controls.Add(before:=2, Type:=msoControlPopup)
With pop2
    pop2.Caption = cp3
    End With
With cbu.CommandBar.Controls.Add(before:=3, Type:=msoControlButton)
    .Caption = cp4
    .OnAction = "benenne_marke"
    End With
With cbu.CommandBar.Controls.Add(before:=4, Type:=msoControlButton)
    .Caption = cp5
    .OnAction = "Reset"
    .BeginGroup = True
    End With
With cbu.CommandBar.Controls.Add(before:=5, Type:=msoControlDropdown)
    .AddItem tx1, 1
    .Tag = "EinzelnLoeschen"
    .OnAction = ThisWorkbook.Name & "!'Loesche'"
    .ListHeaderCount = 1
    .ListIndex = 1
    End With
With pop2.CommandBar.Controls.Add(Type:=msoControlButton)
    .Caption = cp6
    .OnAction = "einfuegen_hinter"
    End With
With pop2.CommandBar.Controls.Add(before:=1, Type:=msoControlButton)
    .Caption = cp7
    .OnAction = "einfuegen_vor"
    End With
Exit Sub
FEHLER:
MsgBox msg1, vbCritical, cb_title
End Sub

Sub Reset()
Dim i
On Error Resume Next
With Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar
    For i = .Controls.Count To (l_butts + 1) Step -1
        .Controls(i).Delete
        Next
    For i = .FindControl(Tag:="EinzelnLoeschen").ListCount To 2 Step -1
        .FindControl(Tag:="EinzelnLoeschen").RemoveItem i
        Next
    End With
top_Merker = 0
akt_Merker = 0
global_i = 0
cbu.Caption = cbmark & akt_Merker & "/" & top_Merker
set_my_infos
End Sub

Sub Loesche()
Dim i
On Error GoTo l_Fehler
With Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar
    If global_i = 0 Then
        i = .FindControl(Tag:="EinzelnLoeschen").ListIndex
        Else
        i = global_i + 1 '+1 für die Überschrift!
        End If
    If i > 1 Then  'wenn nicht Überschrift im DropDown ausgewählt
        .FindControl(Tag:="EinzelnLoeschen").RemoveItem i
        .FindControl(Tag:="EinzelnLoeschen").ListIndex = 1
        .Controls(i - 1 + l_butts).Delete 'l_butts für Menüpunkte, -1 für Überschrift im DropDown
        End If
    End With
    If akt_Merker = (i - 1) Then akt_Merker = 0 '-1 für Überschrift
    If top_Merker > 0 Then
        If akt_Merker = top_Merker Then
            akt_Merker = akt_Merker - 1
            End If
        If akt_Merker > top_Merker Then akt_Merker = 0
        top_Merker = top_Merker - 1
        Else
        top_Merker = 0
        akt_Merker = 0
        End If
l_Fehler:
global_i = 0 'reset global_i
cbu.Caption = cbmark & akt_Merker & "/" & top_Merker
set_my_infos
End Sub

Sub SavePosition()
Dim SMName$
On Error GoTo FEHLER
If TypeName(Selection) <> "Range" Then
    MsgBox msg2, vbInformation
    Exit Sub
    End If
SMName = ""
If n_check.Parameter Then
    SMName = InputBox(msg3 & Chr(10) & msg31, cb_title)
End If
If SMName = "" Then SMName = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False, external:=True)
If Not IsEmpty(ActiveCell) Then
    If Len(ActiveCell) > 10 Then
        SMName = SMName & " (" & Left(ActiveCell, 10) & "...)"
        Else
        SMName = SMName & " (" & ActiveCell & ")"
        End If
    End If
With Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar.Controls.Add(Type:=msoControlButton)
    If global_i > 0 Then 'verschiebe den Button!
        .Move , global_i + l_butts
        'global_i = 0 wird wegen Einzellöschungsliste weiter unten nochmals benötigt!
        End If
    .Caption = SMName
    .OnAction = ThisWorkbook.Name & "!'Springe """ & Selection.Address(ReferenceStyle:=xlR1C1, external:=True) & """'"
    If .Index = (l_butts + 1) Then .BeginGroup = True
    .TooltipText = Selection.Address(RowAbsolute:=False, ColumnAbsolute:=False, external:=True)
    .Parameter = SMName 'sichern für die spätere Änderung der Statusbar- u. Tooltipanzeige
    End With
If global_i = 0 Then
    Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar.FindControl(Tag:="EinzelnLoeschen").AddItem SMName
    Else
    Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar.FindControl(Tag:="EinzelnLoeschen").AddItem SMName, global_i + 1
    End If
If max_Merker > 0 Then
    If top_Merker >= max_Merker Then
        global_i = 1
        Loesche
        End If
    End If
top_Merker = top_Merker + 1
If global_i > 0 Then
    akt_Merker = akt_Merker + 1
    Else
    akt_Merker = top_Merker
    End If
global_i = 0 'verschobener Reset von oben!
cbu.Caption = cbmark & akt_Merker & "/" & top_Merker
set_my_infos
Exit Sub
FEHLER:
MsgBox msg4, vbCritical, cb_title
End Sub

Sub Springe(i)
On Error GoTo FEHLER
Application.GoTo Reference:="=" & i
cbu.Caption = cbmark & akt_Merker & "/" & top_Merker
set_my_infos
Exit Sub
FEHLER:
MsgBox msg5 & Chr(10) & msg51, vbInformation, cb_title
End Sub

Private Sub change_n_check()
With n_check
    If .FaceId = face_2 Then
        .FaceId = face_1
        .Parameter = False
        .TooltipText = t_tip1
        Else
        .FaceId = face_2
        .Parameter = True
        .TooltipText = t_tip2
        End If
    End With
End Sub

Private Sub change_merker()
Dim delta, i As Integer
On Error GoTo m_Fehler

With m_change
   max_Merker = CInt(InputBox(msgi1 & Chr(10) & msgi11, msgit, max_Merker))
   If max_Merker = 0 Then
       .Caption = Chr(216) 'Zeichen Durchschnitt
       Else
       .Caption = CStr(max_Merker)
       If top_Merker > max_Merker Then 'lösche evtl. einige Sprungmarken?
           delta = top_Merker - max_Merker
           For i = 1 To delta
              global_i = 1
              Loesche
           Next i
           End If
       End If
   End With
cbu.Caption = cbmark & akt_Merker & "/" & top_Merker
set_my_infos
Exit Sub
m_Fehler:
MsgBox msg6, vbCritical, msgit
End Sub

Private Sub benenne_marke()
Dim SMName$
On Error Resume Next
If akt_Merker > 0 Then
    With Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar.Controls(akt_Merker + l_butts) 'l_butts für Menüpunkte oberhalb
        SMName = .Caption
        SMName = InputBox(msgi2 & Chr(10) & msgi21, cb_title, SMName)
        If SMName > "" Then
            .Caption = SMName
            .Parameter = SMName
            set_my_infos
            End If
        End With
    End If
End Sub

Sub springe_minus()
On Error Resume Next
Select Case akt_Merker
    Case 0, 1: 'aktuelle Position unbekannt (evtl gelöscht?) oder am Anfang
       If top_Merker > 0 Then akt_Merker = top_Merker
    Case Else: akt_Merker = akt_Merker - 1
    End Select
If akt_Merker > 0 Then
    With Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar
         .Controls(l_butts + akt_Merker).Execute
         End With
    End If
End Sub

Sub springe_plus()
On Error Resume Next
Select Case akt_Merker
    Case 0:  'aktuelle Position unbekannt
       If top_Merker > 0 Then akt_Merker = 1 'wenn top_Merker =0, dann ist Liste leer
    Case top_Merker: 'aktuelle Position am Ende
       If top_Merker > 0 Then akt_Merker = 1 'wenn top_Merker =0, dann ist Liste leer
    Case Is > top_Merker: 'aktuelle Position hinter dem Ende
       akt_Merker = top_Merker 'setze ans Ende
    Case Else: akt_Merker = akt_Merker + 1
    End Select
If akt_Merker > 0 Then
    With Application.CommandBars(cb_title).FindControl(Tag:="gemerkt").CommandBar
         .Controls(l_butts + akt_Merker).Execute
         End With
    End If
End Sub

Sub loesche_akt_marke()
Dim old_merker As Integer
old_merker = 0
If akt_Merker > 0 Then
   global_i = akt_Merker
   old_merker = akt_Merker
   End If
Loesche
akt_Merker = old_merker - 2
springe_plus
End Sub

Private Sub einfuegen_marke(einfuegen_vor As Boolean)
On Error GoTo einfuege_fehler

Select Case akt_Merker
    Case Is <= 0:
        akt_Merker = 0
        global_i = 0
        GoTo glob_gesetzt
    Case 1:
        If einfuegen_vor Then
            akt_Merker = 0
            global_i = 1
            Else
            global_i = 2
            End If
        GoTo glob_gesetzt
    Case Is > top_Merker:
        akt_Merker = top_Merker
        global_i = 0 'einfach nur dahinter anhängen
        GoTo glob_gesetzt
    Case top_Merker:
        If einfuegen_vor Then
            akt_Merker = akt_Merker - 1
            global_i = top_Merker
            Else
            global_i = 0 'einfach nur dahinter anhängen
            End If
        GoTo glob_gesetzt
    Case Else:
        If einfuegen_vor Then
            global_i = akt_Merker
            akt_Merker = akt_Merker - 1
            Else
            global_i = akt_Merker + 1
            End If
    End Select
glob_gesetzt:
SavePosition

If top_Merker > max_Merker Then
    global_i = 1
    Loesche
    End If

Exit Sub
einfuege_fehler:
MsgBox msg7 & Chr(10) & msg71 & Chr(10) & msg72
End Sub

Private Sub einfuegen_hinter()
    pop2.Caption = cp31
    einfuegen_marke (False)
End Sub

Private Sub einfuegen_vor()
    pop2.Caption = cp32
    einfuegen_marke (True)
End Sub

Private Sub set_my_infos()
If akt_Merker > 0 Then
    Application.StatusBar = CStr(cbu.Controls(akt_Merker + l_butts).Parameter)
    cbu.TooltipText = CStr(cbu.Controls(akt_Merker + l_butts).Parameter)
    Else
    Application.StatusBar = ""
    cbu.TooltipText = ""
    End If
End Sub