Automatische Vergabe einer Rechnungsnummer in Word2010

Option Explicit

Private RegistryEventHandler As New EventClassModule    'Word-Ereignisse in Klassenmodul aktivieren  

Private Sub Document_New()
    Set oNewDoc = ActiveDocument
    Set RegistryEventHandler.AppWord = Word.Application
    Call InitCounter
End Sub

Option Explicit

'Registry-Path HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Word Rechnung\Settings\Counter  
Public Const RegAppName = "Word Rechnung"  
Public Const RegSecName = "Settings"  
Public Const RegKeySave = "Counter"  

Public oNewDoc As Document, iCounter As Long

Public Sub InitCounter()
    iCounter = GetSetting(RegAppName, RegSecName, RegKeySave, 1)
    Call CreateCommandBar
    Call InitBookmarkReNr
End Sub

Private Sub CreateCommandBar()
    With CommandBars.Add(Name:="Rechn.-Nr.", Temporary:=True)  
        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .Caption = "Counter:"  
        End With
        
        With .Controls.Add(Type:=msoControlEdit)
            .Text = iCounter
            .Width = 60
            .TooltipText = "Aktuelle Rechnungs-Nr. anzeigen (Änderung mit Return übernehmen)"  
            .OnAction = "ButtonEdit_Click"  
        End With
       
       .Visible = True
    End With
End Sub

Public Sub ButtonEdit_Click()
    Dim Value As Variant
    
    Value = CommandBars("Rechn.-Nr.").Controls(2).Text  
    
    If IsNumeric(Value) Then
        iCounter = Value
        Call SaveSetting(RegAppName, RegSecName, RegKeySave, iCounter)
        Call InitBookmarkReNr
    Else
        MsgBox "Bitte nur numerische Werte eingeben!", vbExclamation, "Fehler..."  
    End If
End Sub

Private Sub InitBookmarkReNr()
    If ActiveDocument.Bookmarks.Exists("ReNr") Then  
        With ActiveDocument.Bookmarks("ReNr").Range.Words(1)  
            If .Characters(1) > " " Then .Delete  
           .InsertBefore iCounter
        End With
    Else
        MsgBox "Die Textmarke 'ReNr' nicht gefunden!", vbExclamation, "Fehler..."  
    End If
End Sub

Option Explicit

'Rechnungsname bei Bedarf anpassen (%y=YYYY, %m=MM, %d=DD, %i=ReNr)  
Private Const sDocName = "Rechnung %y-%m-%d#%i"    'Beispiel: "Rechnung 2012-08-03#12"  

Public WithEvents AppWord As Word.Application

Private Sub AppWord_DocumentBeforeSave(ByVal Doc As Document, ByRef SaveAsUI As Boolean, ByRef Cancel As Boolean)
    Dim Template As Object
    
    For Each Template In Templates
        If LCase(Template.Name) = "rechnung.dot" Then Template.Saved = True  
    Next
    
    If SaveAsUI And Doc.Name = oNewDoc.Name Then
        With Dialogs(wdDialogFileSaveAs)
            .Name = GetDocName
             If .Show Then Call SaveSetting(RegAppName, RegSecName, RegKeySave, iCounter + 1)
        End With
        Cancel = True:  SaveAsUI = False
    End If
End Sub

Private Sub AppWord_DocumentBeforeClose(ByVal Doc As Document, ByRef Cancel As Boolean)
    Dim Template As Object
    
    For Each Template In Templates
        If LCase(Template.Name) = "rechnung.dot" Then Template.Saved = True  
    Next
End Sub

Private Function GetDocName() As String
    Dim aReplace As Variant, i As Integer
    
    GetDocName = sDocName
    
    aReplace = Array("%y", Year(Date), "%m", Right("0" & Month(Date), 2), "%d", Right("0" & Day(Date), 2), "%i", iCounter)  
    
    For i = 0 To UBound(aReplace) Step 2
        GetDocName = Replace(GetDocName, aReplace(i), aReplace(i + 1))
    Next
End Function

Option Explicit

Private RegistryEventHandler As New EventClassModule    'Word-Ereignisse in Klassenmodul aktivieren  

Private Sub Document_New()
    Set oNewDoc = ActiveDocument
    Set RegistryEventHandler.AppWord = Word.Application
    Call InitCounter
End Sub

Option Explicit

'Registry-Path HKEY_CURRENT_USER\Software\VB and VBA Program Settings\Word Rechnung\VorlageName\Counter  
Public Const RegAppName = "Word Rechnung"  
Public Const RegKeySave = "Counter"  

Public oNewDoc As Document, iCounter As Long

Public Sub InitCounter()
    iCounter = GetSetting(RegAppName, oNewDoc.AttachedTemplate.Name, RegKeySave, 1)
    Call CreateCommandBar(iCounter)
    Call InitBookmarkReNr
End Sub

Private Sub CreateCommandBar(ByVal Counter As Long)
    With CommandBars.Add(Name:="Rechn.-Nr.", Temporary:=True)  
        With .Controls.Add(Type:=msoControlButton)
            .Style = msoButtonCaption
            .Caption = "Counter:"  
        End With
        
        With .Controls.Add(Type:=msoControlEdit)
            .Text = Counter
            .Width = 60
            .TooltipText = "Aktuelle Rechnungs-Nr. anzeigen (Änderung mit Return übernehmen)"  
            .OnAction = "ButtonEdit_Click"  
        End With
       
       .Visible = True
    End With
End Sub

Public Sub ButtonEdit_Click()
    Dim Value As Variant
    
    Value = CommandBars("Rechn.-Nr.").Controls(2).Text  
    
    If IsNumeric(Value) Then
        iCounter = Value
        Call SaveSetting(RegAppName, oNewDoc.AttachedTemplate.Name, RegKeySave, iCounter)
        Call InitBookmarkReNr
    Else
        MsgBox "Bitte nur numerische Werte eingeben!", vbExclamation, "Fehler..."  
    End If
End Sub

Private Sub InitBookmarkReNr()
    If ActiveDocument.Bookmarks.Exists("ReNr") Then  
        With ActiveDocument.Bookmarks("ReNr").Range.Words(1)  
            If .Characters(1) > " " Then .Delete  
           .InsertBefore iCounter
        End With
    Else
        MsgBox "Die Textmarke 'ReNr' nicht gefunden!", vbExclamation, "Fehler..."  
    End If
End Sub

Option Explicit

'Rechnungsname bei Bedarf anpassen (%y=YYYY, %m=MM, %d=DD, %i=ReNr)  
Private Const sDocName = "Rechnung %y-%m-%d#%i"    'Beispiel: "Rechnung 2012-08-03#12"  

Public WithEvents AppWord As Word.Application

Private Sub AppWord_DocumentBeforeSave(ByVal Doc As Document, ByRef SaveAsUI As Boolean, ByRef Cancel As Boolean)
    oNewDoc.AttachedTemplate.Saved = True
    
    If SaveAsUI And Doc.Name = oNewDoc.Name Then
        With Dialogs(wdDialogFileSaveAs)
            .Name = GetDocName
             If .Show Then Call SaveSetting(RegAppName, oNewDoc.AttachedTemplate.Name, RegKeySave, iCounter + 1)
        End With
        Cancel = True:  SaveAsUI = False
    End If
End Sub

Private Sub AppWord_DocumentBeforeClose(ByVal Doc As Document, ByRef Cancel As Boolean)
    oNewDoc.AttachedTemplate.Saved = True
End Sub

Private Function GetDocName() As String
    Dim aReplace As Variant, i As Integer
    
    GetDocName = sDocName
    
    aReplace = Array("%y", Year(Date), "%m", Right("0" & Month(Date), 2), "%d", Right("0" & Day(Date), 2), "%i", iCounter)  
    
    For i = 0 To UBound(aReplace) Step 2
        GetDocName = Replace(GetDocName, aReplace(i), aReplace(i + 1))
    Next
End Function