Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "0{00020906-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Form_InsertAddress"
Attribute VB_Base = "0{298112AF-4063-4CC1-9A07-39279B0A6842}{65AC5AA9-517F-413B-BE42-6B757C631C26}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
' **************************************************
' * SCHAEFER Business Solutions
' *
' * Email : info@schaefer-bs.com
' * WWW   : www.schaefer-bs.com
' **************************************************

Option Explicit

Private Const ROOT_KEY = "$$$ROOT$$$"
Private Const PREFIX_ADDRESS = "ADDRESS_"
Private Const ITEM_DELIMITER = "%%%"
Private tree As TreeView
Private ROOT As Node

'eWorks
Private Const MODULE_NAME = "Form_InsertAddress"
Private WithEvents meOutlookApplication As Outlook.Application
Attribute meOutlookApplication.VB_VarHelpID = -1
Private meOutlookSearchComp As Boolean
Private meOutlookResults As Outlook.Results


Private Sub CMD_Cancel_2_Click()
    Unload Me
End Sub

' *****************************************************************************************
' * Doings                 : Abbruch
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub CMD_CANCEL_Click()
    Unload Me
End Sub

' *****************************************************************************************
' * Doings                 : Fügt ausgewählte Addresse ein
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Function insertAddresses() As Boolean
    Dim addressnode As Variant
    Dim archpath As String
    Dim arch As Variant
    Dim addresspath As String
    Dim addressindex As Long
    Dim address As Variant
    Dim help As Integer
    
    On Error GoTo AddressError
    
    ' Prüfe auswahl
    Set addressnode = tree.SelectedItem
    If IsNull(addressnode) Or (addressnode Is Nothing) Then
        MsgBox "Sie müssen eine Addresse auswählen, oder drücken Sie 'Abbruch'!", vbInformation, "Information"
        insertAddresses = False
        Exit Function
    End If
    If Left(addressnode.key, Len(PREFIX_ADDRESS)) <> PREFIX_ADDRESS Then
        MsgBox "Sie müssen eine Addresse auswählen, oder drücken Sie 'Abbruch'!", vbInformation, "Information"
        insertAddresses = False
        Exit Function
    End If
    
    ' Holen des Eintrags
    help = InStr(1, addressnode.key, ITEM_DELIMITER, vbTextCompare)
    addresspath = Mid(addressnode.key, Len(PREFIX_ADDRESS) + 1, help - Len(PREFIX_ADDRESS) - 1)
    addressindex = CLng(Mid(addressnode.key, help + Len(ITEM_DELIMITER)))
    'archpath = addressnode.Parent.Tag
    Set arch = dv_account.GetArchive(addresspath) 'ArchiveFromID(archpath)
    'If archpath = "" Then
    '
    'Else
    'End If
    Set address = arch.AddressBook.Item(addressindex + 1)
    ' Ersetze text
    replaceAddress_old address.AddressItem, dv_account.User.VCard
    
    insertAddresses = True
    
    Exit Function
AddressError:
    MsgBox "Ein Fehler ist beim Einfügen der Addresse aufgetreten:" & Err.Description
End Function


'eWorks: Einfügen des ausgewählten Kontakts ins Dokument
Private Sub CMD_Weiter_2_Click()
    On Error GoTo Catch
    
    Dim outlookContact As eWorksAddressItem
    
    If lst_Result.ListIndex = -1 Then
        MsgBox "Sie müssen eine Addresse auswählen, oder drücken Sie 'Abbruch'!", vbInformation, "Information"
        Exit Sub
    Else
        Set outlookContact = New eWorksAddressItem
        Set outlookContact.ContactItem = meOutlookResults.Item(lst_Result.ListIndex + 1)
        
        replaceAddress_old outlookContact, dv_account.User.VCard
    
    End If
    
Finally:
    Unload Me
    Exit Sub
Catch:
    eWorksVBA.HandleError Err, MODULE_NAME, "CMD_Weiter_2_Click", True
    GoTo Finally
End Sub


'eWorks: Suche mit Enter-Taste
Private Sub txt_SearchName_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
        CMD_SearchName_Click
    End If
End Sub

'eWorks: Event-Handler zur Festellung wann die Suche beendet ist
Private Sub meOutlookApplication_AdvancedSearchComplete(ByVal SearchObject As Search)
    meOutlookSearchComp = True
End Sub

'eWorks: Namensuche in Outlook
Private Sub CMD_SearchName_Click()
    On Error GoTo Catch
    
    Dim outlookSearch As Outlook.Search
    Dim outlookResult As Variant
    
    Dim searchString As String
    Dim scopeString As String
    
    
    
    'Liste leeren
    lst_Result.Clear
    
    Set meOutlookApplication = New Outlook.Application
    
    searchString = "urn:schemas:contacts:cn like '%" & txt_SearchName & "%' or urn:schemas:contacts:o like '%" & txt_SearchName & "%'" 'Suche im FullName und CompanyName
    'searchString = "urn:schemas:mailheader:subject like '%" & txt_SearchName & "%'"
    scopeString = eWorksOutlook.Application.Session.AddressLists.Item(CONTACT_FOLDER_NAME).GetContactsFolder.folderPath
    
    meOutlookSearchComp = False
    

    lst_Result.MousePointer = fmMousePointerHourGlass
    lbl_SearchProgress.Caption = "Suche läuft..."
    
    Set outlookSearch = meOutlookApplication.AdvancedSearch("'" & scopeString & "'", searchString, True, "Test")
    
    'Warten bis Suche abgeschlossen ist
    While meOutlookSearchComp = False And _
        Not outlookSearch.IsSynchronous
        
        DoEvents
    Wend
    
    lst_Result.MousePointer = fmMousePointerDefault
    lbl_SearchProgress.Caption = "Suche beendet"
    
    lst_Result.Clear
    Set meOutlookResults = outlookSearch.Results
    
    If meOutlookResults.Count = 0 Then
        eWorksVBA.ShowInformation "Der gesuchte Name konnte nicht gefunden werden."
    Else
        For Each outlookResult In meOutlookResults
            
            If TypeOf outlookResult Is Outlook.ContactItem Then
                'lst_Result.AddItem eWorksString.ReduceStringToGerman(outlookResult.Subject, , " ,")
                
                lst_Result.AddItem outlookResult.Subject & " (" & outlookResult.CompanyName & ")"

            End If
        
        Next outlookResult
        
        'Workarroud, damit Listeneinträge nicht abgeschnitten werden
        lst_Result.columnWidths = "1000pt"
        lst_Result.columnWidths = ""
    End If
    
Finally:
    lst_Result.MousePointer = fmMousePointerDefault
    lbl_SearchProgress.Caption = ""
    Exit Sub
Catch:
    eWorksVBA.HandleError Err, MODULE_NAME, "CMD_SearchName_Click", True
    GoTo Finally
End Sub

' *****************************************************************************************
' * Doings                 : Schaltfläche Einfügen -> Einfügen Addresse
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub CMD_Weiter_Click()
    If insertAddresses Then
        Unload Me
    End If
End Sub

' *****************************************************************************************
' * Doings                 : Listet die Archive des gegebenen Archives auf
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub readArchive(currentnode As Node, uncpath As String)
    Dim parentarch As eWorksArchive  'Variant ' DvApi32.Archive
    Dim subarch As eWorksArchive  ' Variant ' DvApi32.Archive
    Dim arch As eWorksArchive  ' Variant ' DvApi32.Archive
    Dim parentnode As Node
    Dim newnode As Node
        
    On Error GoTo ErrHandle
    If currentnode.Children = 0 Then
        Set parentarch = dv_account.GetArchive(uncpath) 'dv_account.ArchiveFromID(archid)
        ' Read addresses in parentarchive
        readAddresses currentnode, parentarch
        ' List parentarch
        For Each arch In parentarch.archives
            'Debug.Print arch.ID & vbTab & arch.DisplayName
            Set parentnode = tree.Nodes.Add( _
                                currentnode.key, _
                                tvwChild, _
                                arch.ID, _
                                GetParsedDisplayName(arch.DisplayName), _
                                "Folder")
            parentnode.Tag = arch.ID
            parentnode.Sorted = True
            ' Read addresses in archive
            readAddresses parentnode, arch
            ' Read subarchives
            For Each subarch In arch.archives
                Set newnode = tree.Nodes.Add( _
                                parentnode.key, _
                                tvwChild, _
                                subarch.ID, _
                                GetParsedDisplayName(subarch.DisplayName), _
                                "Folder")
                newnode.Tag = subarch.ID
                newnode.Sorted = True
            Next
        Next
    End If
    Exit Sub
ErrHandle:
    MsgBox "Auf das Archive mit dem Pfad '" & uncpath & "' konnte nicht zugegriffen werden : " & vbCrLf & vbCrLf & _
           "Grund war : " & Err.Description, vbExclamation, DIALOGTITLE_ERROR
End Sub

' *****************************************************************************************
' * Doings                 : Listet die Addressen des gegebenen Archives auf
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub readAddresses(archnode As Node, arch As Variant)
    Dim addr As eWorksAddress    'Variant ' DvApi32.Address
    Dim Count As Integer
    Dim n As Node

    Count = 0
    For Each addr In arch.AddressBook
        Set n = tree.Nodes.Add( _
                    archnode.key, _
                    tvwChild, _
                    PREFIX_ADDRESS & arch.ID & ITEM_DELIMITER & Count, _
                    addr.DisplayName, _
                    "Address")
        Count = Count + 1
    Next
    
End Sub

' *****************************************************************************************
' * Doings                 : Lädt Unterarchive und Addressen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub loadArchive()
    Dim n As Node
    Set n = tree.SelectedItem
    If Not (n Is Nothing) Then
        If n.key = ROOT_KEY Then
            readArchive ROOT, DV_SELECTARCHIVE
        Else
            If Left(n.key, Len(PREFIX_ADDRESS)) <> PREFIX_ADDRESS Then
                readArchive n, n.key
            End If
        End If
    End If
End Sub



' *****************************************************************************************
' * Doings                 : Lädt Unterarchive und Addressen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub tree_Archiv_Click()
    loadArchive
End Sub

' *****************************************************************************************
' * Doings                 : Fügt Addresse ein
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 28.10.2003
' *****************************************************************************************
Private Sub tree_Archiv_DblClick()
    Dim addressnode As Variant
    ' Prüfe auswahl
    Set addressnode = tree.SelectedItem
    If IsNull(addressnode) Or (addressnode Is Nothing) Then
        Exit Sub
    End If
    If Left(addressnode.key, Len(PREFIX_ADDRESS)) <> PREFIX_ADDRESS Then
        Exit Sub
    End If
    If insertAddresses Then
        Unload Me
    End If
End Sub

' *****************************************************************************************
' * Doings                 : Lädt Unterarchive und Addressen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub tree_Archiv_Expand(ByVal Node As MSComctlLib.Node)
    loadArchive
End Sub




' *****************************************************************************************
' * Doings                 : Lädt das Formular
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 31.08.2003
' *****************************************************************************************
Private Sub UserForm_Activate()
    Dim uncpath As String
    ' Lade Addressen
    Set tree = Me.Controls("tree_Archiv")
    Set tree.ImageList = imagelist_Tree
    ' Verbinde zu DAVID
    If DavidLogon Then
        uncpath = dv_account.GetSpecialArchive(DV_SELECTARCHIVE).ID
        Set ROOT = tree.Nodes.Add(, , ROOT_KEY, dv_account.Description, "Archive")
        ROOT.Sorted = True
        readArchive ROOT, uncpath
        ROOT.Expanded = True
    Else
        MsgBox "Fehler beim Zugriff auf DAVID.", vbExclamation, DIALOGTITLE_ERROR
        Unload Me
    End If
End Sub

' *****************************************************************************************
' * Doings                 : Entlädt das Formular
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 31.08.2003
' *****************************************************************************************
Private Sub UserForm_Terminate()
    DavidLogoff
End Sub



Attribute VB_Name = "Form_SelectPrinter"
Attribute VB_Base = "0{6ECE0DC1-88A4-4943-A36B-2DACA09BF0AF}{0118E09C-F9D1-457C-AAED-34FB2B324B08}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
' **************************************************
' * SCHAEFER Business Solutions
' *
' * Email : info@schaefer-bs.com
' * WWW   : www.schaefer-bs.com
' **************************************************

Option Explicit
    
' *****************************************************************************************
' * Doings                 : Abbruch
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 18.08.2003 13:00
' *****************************************************************************************
Private Sub CMD_CANCEL_Click()
    Form_SelectPrinter.Hide
    Unload Form_SelectPrinter
End Sub

' *****************************************************************************************
' * Doings                 : Druckt das aktuelle Dokument aus
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 18.08.2003 13:00
' *****************************************************************************************
Private Sub CMD_PRINT_Click()
    If Me.CMB_PRINTERS <> "" Then
        On Error GoTo ErrHandle
        SetPrinterTray
        SetPrinterByWordBasic Me.CMB_PRINTERS
        ActiveDocument.PrintOut
    Else
        MsgBox "Bitte wählen Sie einen Drucker aus!", vbExclamation, "Fehler"
    End If
    
    Unload Me
    Exit Sub
    
ErrHandle:
    MsgBox "Beim Versuch, auf den Drucker " & Me.CMB_PRINTERS & " zuzugreifen, ist der " & _
           " folgende Fehler aufgetreten : " & Err.Description
End Sub

' *****************************************************************************************
' * Doings                 : Lädt das Druckerauswahl Formular und füllt das Kombinationsfeld
' *                          mit Werten
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 18.08.2003 13:00
' *****************************************************************************************
Private Sub UserForm_Activate()
    Dim StrPrinters As Variant
    Dim p As Long
    
    StrPrinters = ListPrinters
    If Not IsNull(StrPrinters) Then
        ' Drucker auswählen
        For p = LBound(StrPrinters) To UBound(StrPrinters)
            Me.CMB_PRINTERS.AddItem StrPrinters(p)
        Next
    Else
        MsgBox "Leider keine Drucker verfügbar!", vbExclamation, "Fehler"
    End If
  
End Sub




Attribute VB_Name = "Form_SelectAddresses"
Attribute VB_Base = "0{CEB753F5-59D7-434C-86F0-5BEB70864C9C}{C80027BE-4B6F-4F34-84FB-12776D0FBE39}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
' **************************************************
' * SCHAEFER Business Solutions
' *
' * Email : info@schaefer-bs.com
' * WWW   : www.schaefer-bs.com
' **************************************************

Option Explicit

Private tree As TreeView
Private ROOT As Node
Private selecteditems As Scripting.Dictionary

' *****************************************************************************************
' * Doings                 : Hinzufügen zur Liste
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 08.12.2003
' *****************************************************************************************
Private Sub CMD_ADD_Click()
    Dim addressnode
    
    ' Prüfe auswahl
    Set addressnode = tree.SelectedItem
    If IsNull(addressnode) Or (addressnode Is Nothing) Then
        MsgBox "Zum Einfügen müssen Sie eine Addresse auswählen!", vbInformation, "Information"
        Exit Sub
    End If
    If Left(addressnode.key, Len(PREFIX_ADDRESS)) <> PREFIX_ADDRESS Then
        MsgBox "Zum Einfügen müssen Sie eine Addresse auswählen!", vbInformation, "Information"
        Exit Sub
    End If
    
    If Not selecteditems.Exists(CStr(addressnode.key)) Then
        Me.LST_ADDRESSES.AddItem CStr(addressnode.Text)
        selecteditems.Add Me.LST_ADDRESSES.ListCount, CStr(addressnode.key)
    End If
End Sub

' *****************************************************************************************
' * Doings                 : Aus Liste entfernen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 14.12.2003
' *****************************************************************************************
Private Sub CMD_DEL_Click()
    Dim remindex As Integer
    Dim Count As Integer
    Dim i As Integer
    
    Count = Me.LST_ADDRESSES.ListCount
    remindex = Me.LST_ADDRESSES.ListIndex + 1
    If remindex > 0 Then
        Me.LST_ADDRESSES.RemoveItem (remindex - 1)
        For i = remindex To Count
            selecteditems.Remove i
            If remindex < Count Then
                selecteditems.Add i, selecteditems.Item(i + 1)
            End If
        Next
    End If
End Sub


' *****************************************************************************************
' * Doings                 : Abbruch
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub CMD_CANCEL_Click()
    Unload Me
End Sub

' *****************************************************************************************
' * Doings                 : Listet die Archive des gegebenen Archives auf
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub readArchive(currentnode As Node, uncpath As String)
    Dim parentarch As Variant ' DvApi32.Archive
    Dim subarch As Variant ' DvApi32.Archive
    Dim arch As Variant ' DvApi32.Archive
    Dim parentnode As Node
    Dim newnode As Node
        
    On Error GoTo ErrHandle
    If currentnode.Children = 0 Then
        Set parentarch = dv_account.GetArchive(uncpath) 'dv_account.ArchiveFromID(archid)
        ' Read addresses in parentarchive
        readAddresses currentnode, parentarch
        ' List parentarch
        For Each arch In parentarch.archives
            Set parentnode = tree.Nodes.Add( _
                                currentnode.key, _
                                tvwChild, _
                                arch.ID, _
                                GetParsedDisplayName(arch.DisplayName), _
                                "Folder")
            parentnode.Tag = arch.ID
            parentnode.Sorted = True
            ' Read addresses in archive
            readAddresses parentnode, arch
            ' Read subarchives
            For Each subarch In arch.archives
                Set newnode = tree.Nodes.Add( _
                                parentnode.key, _
                                tvwChild, _
                                subarch.ID, _
                                GetParsedDisplayName(subarch.DisplayName), _
                                "Folder")
                newnode.Tag = subarch.ID
                newnode.Sorted = True
            Next
        Next
    End If
    Exit Sub
ErrHandle:
    MsgBox "Auf das Archive mit dem Pfad '" & uncpath & "' konnte nicht zugegriffen werden : " & vbCrLf & vbCrLf & _
           "Grund war : " & Err.Description, vbExclamation, DIALOGTITLE_ERROR
End Sub

' *****************************************************************************************
' * Doings                 : Listet die Addressen des gegebenen Archives auf
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub readAddresses(archnode As Node, arch As Variant)
    Dim addr As Variant ' DvApi32.Address
    Dim Count As Integer
    Dim n As Node
    
    Count = 0
    For Each addr In arch.AddressBook
        Set n = tree.Nodes.Add( _
                    archnode.key, _
                    tvwChild, _
                    PREFIX_ADDRESS & arch.ID & ITEM_DELIMITER & Count, _
                    addr.DisplayName, _
                    "Address")
        Count = Count + 1
    Next
End Sub

' *****************************************************************************************
' * Doings                 : Lädt Unterarchive und Addressen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub loadArchive()
    Dim n As Node
    Set n = tree.SelectedItem
    If Not (n Is Nothing) Then
        If n.key = ROOT_KEY Then
            readArchive ROOT, DV_SELECTARCHIVE
        Else
            If Left(n.key, Len(PREFIX_ADDRESS)) <> PREFIX_ADDRESS Then
                readArchive n, n.key
            End If
        End If
    End If
End Sub

' *****************************************************************************************
' * Doings                 : Fertigstellen ... Etikett erzeugen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 08.12.2003
' *****************************************************************************************
Private Sub CMD_DONE_Click()
   printlabels Me.CMB_ETIKETT, Me.LeerEtiketten, Me.CMB_AFormat, selecteditems
   Unload Me
End Sub

' *****************************************************************************************
' * Doings                 : Lädt Unterarchive und Addressen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub tree_Archiv_Click()
    loadArchive
End Sub

' *****************************************************************************************
' * Doings                 : Fügt Addresse ein
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 28.10.2003
' *****************************************************************************************
Private Sub tree_Archiv_DblClick()
    Dim addressnode As Variant
    ' Prüfe auswahl
    Set addressnode = tree.SelectedItem
    If IsNull(addressnode) Or (addressnode Is Nothing) Then
        Exit Sub
    End If
    If Left(addressnode.key, Len(PREFIX_ADDRESS)) <> PREFIX_ADDRESS Then
        Exit Sub
    End If
    CMD_ADD_Click
End Sub

' *****************************************************************************************
' * Doings                 : Lädt Unterarchive und Addressen
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Private Sub tree_Archiv_Expand(ByVal Node As MSComctlLib.Node)
    loadArchive
End Sub

' *****************************************************************************************
' * Doings                 : Lädt das Formular
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 31.08.2003
' *****************************************************************************************
Private Sub UserForm_Activate()
    Dim uncpath As String
    Dim doc As Document
    Dim w As Window
    
    ' Lade Addressen
    Set tree = Me.Controls("tree_Archiv")
    Set tree.ImageList = imagelist_Tree
    ' Verbinde zu DAVID
    If DavidLogon Then
        uncpath = dv_account.GetSpecialArchive(DV_SELECTARCHIVE).ID
        Set ROOT = tree.Nodes.Add(, , ROOT_KEY, dv_account.Description, "Archive")
        ROOT.Sorted = True
        readArchive ROOT, uncpath
        ROOT.Expanded = True
        Set selecteditems = New Scripting.Dictionary
        ' Etiketten einfügen
        With Me.CMB_ETIKETT
            .AddItem "Zweckform 3424"
            .Value = "Zweckform 3424"
            .AddItem "Zweckform 3422"
        End With
        With Me.CMB_AFormat
            .AddItem "Normal"
            .Value = "Normal"
            .AddItem "Persönlich"
        End With
        Me.LeerEtiketten = 0
        If Documents.Count = 0 Then
            Documents.Add , , , True
        Else
            For Each doc In Documents
                doc.Activate
            Next
        End If
        For Each w In Windows
            If w.View = wdPrintPreview Then
                MsgBox "Sie können keine Addressetiketten erstellen, solange ein Dokument in der Seitenansicht geöffnet ist!", vbExclamation, DIALOGTITLE_ERROR
                Unload Me
                Exit Sub
            End If
        Next
    Else
        MsgBox "Fehler beim Zugriff auf DAVID.", vbExclamation, DIALOGTITLE_ERROR
        Unload Me
    End If
End Sub

' *****************************************************************************************
' * Doings                 : Entlädt das Formular
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 31.08.2003
' *****************************************************************************************
Private Sub UserForm_Terminate()
    DavidLogoff
End Sub





Attribute VB_Name = "eWorksUser"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit

Private meVcard As eWorksAddressItem

Public Property Get VCard() As eWorksAddressItem

    If meVcard Is Nothing Then
        Set meVcard = New eWorksAddressItem
        Set meVcard.ContactItem = eWorksOutlook.Application.CreateItem(olContactItem)
    End If

    Debug.Assert eWorksVBA.Assert(Not meVcard Is Nothing)
    Set VCard = meVcard
    
End Property


Attribute VB_Name = "eWorksDavidAPI"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit

Private thisLoginOptions As Integer


Public Function Logon() As eWorksAccount
    Set Logon = New eWorksAccount
End Function


Public Property Let LoginOptions(ByVal LoginOptionIndex As Integer)
    thisLoginOptions = LoginOptionIndex
End Property


Public Property Get LoginOptions() As Integer
    LoginOptions = thisLoginOptions
End Property

Attribute VB_Name = "eWorksCollection"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit

' ==============================================================================
' eWorks GmbH
'
' Eine Klasse zur Verwaltung von Auflistungen (analog zu "VBA.Collection").
'
' Benötigte Verweise: "OLE Automation (StdOle2.tlb)"
' ==============================================================================
    
' Name des Moduls (wird vor allem für die Fehlerbehandlung genutzt).
Private Const MODULE_NAME = "eWorksCollection"

' Größe des Grenzenarrays für die Sortierung der Collection.
Private Const SORTING_ARRAY_SIZE = 1024

' 2013-04-15 Alexander Quednau
'Private Const MAGIC_EWORKS_KEY_PREFIX = "§&$%_"
'Private meHighestIndex As Long

' Interner Speicher der eigentlichen Werte (samt Schlüsseln)
Private meValues As Collection

' Interner Speicher der Schlüssel der Werte.
Private meValueKeys As Collection

' Serialisierung: Block-Start und Block-ende
Private Const SERIALIZATION_BLOCK_START As String = "{"
Private Const SERIALIZATION_BLOCK_END As String = "}"

' Verhalten der Collection bzgl. Groß- / Kleinschreibung bei Schlüsselnamen.
Private meKeyCompareMethod As VbCompareMethod

' Verhalten der Collection bzgl. Groß- / Kleinschreibung bei Schlüsselwerten.
Private meValueCompareMethod As VbCompareMethod

' Verhalten bzgl. der Eindeutigkeit der Werte: Duplikate erlaubt oder nicht?
Private meValuesUniqueness As Boolean

Private meKeysIgnoreCase As Boolean

' Definiert, wie eine eWorksCollection zu sortieren ist.
Public Enum SortByEnum
    ByKey
    ByValue
    ByMember
    ByCallback
End Enum

' ==============================================================================
' Liefert das erste (oder optional letzte) Element und entfernt es aus der
' eWorksCollection.
' ==============================================================================
Public Function Pop(Optional ByVal popLastItem As Boolean = False) As Variant

    On Error GoTo Catch
    
    Dim result As Variant
    Dim ItemIndex As Long
    
    Debug.Assert eWorksVBA.Assert(Me.Count > 0)
    
    If popLastItem Then
        ItemIndex = Me.Count
    Else
        ItemIndex = 1
    End If
    
    If IsObject(Me.ItemAt(ItemIndex)) Then
        Set result = Me.ItemAt(ItemIndex)
    Else
        result = Me.ItemAt(ItemIndex)
    End If
    
    Me.RemoveAt ItemIndex
        
Finally:

    On Error GoTo 0
    
    If IsObject(result) Then
        Set Pop = result
    Else
        Pop = result
    End If
    Exit Function
    
Catch:
    
    eWorksVBA.HandleError Err, MODULE_NAME, "Pop", True
    GoTo Finally
    
End Function

' ==============================================================================
' Liefert den nächsten, größeren Schlüssel im Bezug auf den übergebenen. Der
' Datentyp aller Schlüssel muss dabei der selbe sein. Objekte werden nicht
' unterstützt.
' ==============================================================================
Public Function FindNextLagerKey(ByVal itemKey As Variant) As Variant
        
    On Error GoTo Catch
    
    Dim result As Variant
    Dim itemKeyIterator As Variant
    
    Debug.Assert eWorksVBA.Assert(Not IsObject(itemKey))
            
    ' Ggf. den Schlüssel aufbereiten
    If meKeysIgnoreCase Then
        KeyPrepareCase itemKey
    End If
    
    If meKeyCompareMethod = VbCompareMethod.vbBinaryCompare Then
    
        itemKey = PrepareKey(itemKey)
        
    End If
    
    For Each itemKeyIterator In meValueKeys
        
        Debug.Assert eWorksVBA.Assert(TypeName(itemKeyIterator) = TypeName(itemKey))
        
        If itemKeyIterator > itemKey Then
                
            result = itemKeyIterator
            Exit For
            
        End If
    
    Next
        
Finally:

    On Error GoTo 0
    
    FindNextLagerKey = result
    Exit Function
    
Catch:
    
    eWorksVBA.HandleError Err, MODULE_NAME, "FindNextLagerKey", True
    GoTo Finally
    
End Function


' ==============================================================================
' Gibt "Wahr" zurück, falls die Groß/Klein-Schreibung ignoriert wird.
' ==============================================================================
Public Property Get KeysIgnoreCase() As Boolean
    KeysIgnoreCase = meKeysIgnoreCase
End Property


' ==============================================================================
' Stellt ein, ob die Groß-/Klein-Schreibung ignoriert wird. Falls dies von
' "Falsch" auf "Wahr" umgestellt wird, werden alle bisher enthaltenen Elemente
' entfernt und nach ihrer Sortierung neu hinzugefügt - dadurch können Elemente
' überschrieben werden.
' ==============================================================================
Public Property Let KeysIgnoreCase(ByVal ignoreCase As Boolean)
    On Error GoTo 0
    
    Dim backupCollection As eWorksCollection
    Dim currentKey As Variant

    If meKeysIgnoreCase = False And ignoreCase = True And Me.Count > 0 Then
…