Code für Modul1

'Code fuer Modul1

Option Explicit

Private CurrentSheetText As String


Public Function StartsWith(LongText As String, ShortText As String, Optional IgnoreCase As Boolean = False) As Boolean
  If IgnoreCase Then
    StartsWith = (UCase$(Left$(LongText, Len(ShortText))) = UCase$(ShortText))
  Else
    StartsWith = (Left$(LongText, Len(ShortText)) = ShortText)
  End If
End Function

Public Function EndsWith(LongText As String, ShortText As String, Optional IgnoreCase As Boolean = False) As Boolean
  If IgnoreCase Then
    EndsWith = (UCase$(Right$(LongText, Len(ShortText))) = UCase$(ShortText))
  Else
    EndsWith = (Right$(LongText, Len(ShortText)) = ShortText)
  End If
End Function


Private Function SheetText(ByVal Wb As Workbook, ByVal Sh As Object) As String
  Dim NumberOfSheet As Integer, NumberOfSheets As Integer

  NumberOfSheets = Wb.Sheets.Count

  If Sh Is Nothing Then
    NumberOfSheet = 0
  Else
    Debug.Assert Wb Is Sh.Parent
    NumberOfSheet = Sh.Index
  End If

  SheetText = SheetTextImplementation(NumberOfSheet, NumberOfSheets, Sh)

End Function

Private Function SheetTextImplementation(ByVal NumberOfSheet As Integer, ByVal NumberOfSheets As Integer, ByVal Sh As Object) As String
  Dim SheetTypeName As String, SheetTypeNotion As String, SheetName As String
  Dim NumberOfSheetOfType As Integer, NumberOfSheetsOfType As Integer
  Dim testSheet As Object, testSheetIndex As Integer

  If NumberOfSheet <= 0 Then
    SheetTextImplementation = "<kein Blatt gewählt von " + Format(NumberOfSheets) + ">"
    SheetTypeName = ""
  Else
    SheetTypeName = TypeName(Sh)

    SheetName = "<Name nicht verfügbar>"
    On Error Resume Next
      SheetName = Sh.Name
    On Error GoTo 0

    Select Case SheetTypeName
      Case ""
        SheetTypeNotion = "<unbekannt>"
      Case "Worksheet"
        SheetTypeNotion = "Tabelle"
      Case "Chart"
        SheetTypeNotion = "Diagramm"
      Case "DialogSheet"
        SheetTypeNotion = "Dialogblatt"
      Case "Application" 'Dummy-Wert, um unbekannten Statusbar-Inhalt zu signalisieren
        SheetTypeNotion = "*"
      Case Else
        Stop
        SheetTypeNotion = SheetTypeName
    End Select 'SheetTypeName

    NumberOfSheetsOfType = 0
    testSheetIndex = 0: NumberOfSheetOfType = 0
    For Each testSheet In Sh.Parent.Sheets
      If TypeName(testSheet) = SheetTypeName Then
        NumberOfSheetsOfType = NumberOfSheetsOfType + 1
        testSheetIndex = testSheetIndex + 1
        If Sh.Index = testSheet.Index Then 'Sh Is testSheet Then -- funktioniert nicht zuverlässig, warum auch immer
          Debug.Assert NumberOfSheetOfType = 0
          NumberOfSheetOfType = testSheetIndex
        End If
      End If
    Next 'Each testsheet In Sh.Parent.Sheets

    SheetTextImplementation = "Blatt " + Format(NumberOfSheet) + " von " + Format(NumberOfSheets) + " (" + SheetTypeNotion + " " + Format(NumberOfSheetOfType) + " von " + Format(NumberOfSheetsOfType) + " """ + SheetName + """)"
  End If

End Function

Public Sub AddSheetName(ByVal Wb As Workbook, ByVal Sh As Object)

  CurrentSheetText = " " + SheetText(Wb, Sh)

  If VarType(Application.StatusBar) <> vbString Then
    Application.StatusBar = CurrentSheetText
  Else
    If EndsWith(Application.StatusBar, CurrentSheetText) Then
      'do nothing
    Else
      Application.StatusBar = Application.StatusBar + CurrentSheetText
    End If
  End If

End Sub

Public Sub RemoveSheetName(ByVal Wb As Workbook, ByVal Sh As Object)
  Const NumberOfSheetsDummy As Long = 32767, NumberOfSheetDummy As Long = 32766

  'Ermittle tatsächlichen Text, auch wenn das Makro neu gestartet wurde und der StatusBar-Text verloren gegangen ist
  If CurrentSheetText = "" Then
    Dim cShT As String
    Dim cShTPattern As String, cShTSBPattern As String, cShTPatternEmptied As String
    Dim statusBarMatches As Boolean
    Dim statusBarText As Variant

    statusBarText = Application.StatusBar
    cShT = ""
    cShTPattern = ""
    cShTSBPattern = ""
    cShTPatternEmptied = ""

    statusBarMatches = (VarType(statusBarText) <> vbString)

    If Not statusBarMatches Then
      statusBarMatches = (statusBarText = "")
    End If

    If Not statusBarMatches Then
      cShT = SheetTextImplementation(NumberOfSheetDummy, NumberOfSheetsDummy, Application)
      cShTPattern = Replace(Replace(cShT, Format(NumberOfSheetsDummy), "*"), Format(NumberOfSheetDummy), "*")
      cShTSBPattern = "*" + cShTPattern
      statusBarMatches = (statusBarText Like cShTSBPattern)
    End If

    If Not statusBarMatches Then
      cShT = SheetTextImplementation(0, NumberOfSheetsDummy, Application)
      cShTSBPattern = "*" + cShTPattern
      cShTPattern = Replace(Replace(cShT, Format(NumberOfSheetsDummy), "*"), Format(NumberOfSheetDummy), "*")
      statusBarMatches = (statusBarText Like cShTSBPattern)
    End If

    If statusBarMatches Then
      'Rückwärts suchen bis Übereinstimmung gefunden
      cShTPatternEmptied = Replace(cShTPattern, "*", "") 'String für die Länge, ab der gesucht wird - "?" braucht nicht ersetzt zu werden, da es genau 1 Zeichen ist und auch für genau 1 Zeichen steht

      Dim pos As Long, matchAtPos As Boolean

      pos = Len(statusBarText) - Len(cShTPatternEmptied)
      matchAtPos = False

      Do While pos > 0
        If Mid$(statusBarText, pos) Like cShTPattern Then
          matchAtPos = True
          Exit Do
        End If
        pos = pos - 1
      Loop

      If matchAtPos Then
        CurrentSheetText = Mid$(statusBarText, pos)
      End If
    End If
  End If

  If VarType(Application.StatusBar) <> vbString Then 'Application.StatusBar == False (Boolean), wenn in der StatusBar nichts angezeigt werden soll
    Application.StatusBar = ""
  Else
    If EndsWith(Application.StatusBar, CurrentSheetText) Then
      'den Blatt-spezifischen Text entfernen, den Anfang stehenlassen
      Application.StatusBar = Left(Application.StatusBar, Len(Application.StatusBar) - Len(CurrentSheetText))
    Else
      'do nothing
    End If
  End If

End Sub