Attribute VB_Name = "Sprungmarke"
'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.
'
'AKTUELLE VERSION!
'
'http://www.rendar.de/excel/pos_merker.txt (diese Datei!)
'http://www.rendar.de/excel/pos_merker.xls
'http://www.rendar.de/excel/pos_merker.bas (Makros!)
'
'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.
'

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 msg52 = "Um weitere Fehlermeldungen zu vermeiden"
Const msg521 = "öffnen sie die geschlossenen Arbeitsmappe"
Const msg522 = "oder löschen sie die Sprungmarke #"
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
akt_Merker = 0
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)
Dim err_temp As String
On Error GoTo FEHLER
'Rücksprungadresse bei eventuell geschlossener Mappe
'in err_temp zwischenspeichern!
err_temp = Selection.Address(ReferenceStyle:=xlR1C1, external:=True)
Application.GoTo Reference:="=" & i
cbu.Caption = cbmark & akt_Merker & "/" & top_Merker
set_my_infos
Exit Sub
FEHLER:
MsgBox msg5 & Chr(10) & msg51 & Chr(10) & _
       Chr(10) & _
       Chr(10) & _
       msg52 & Chr(10) & _
       msg521 & Chr(10) & _
       msg522 & akt_Merker & Chr(10) & _
       Chr(10) & _
       i, 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