Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 2b6521cc8047e91d…

MALICIOUS

Office (OOXML)

2.55 MB Created: 2018-09-25 08:53:00 UTC Authoring application: Microsoft Office Word 16.0000 First seen: 2020-12-25
MD5: f3f3120a15570d67c57a73486115eefa SHA-1: 55fa4335cdea201daa1da537d9bf969175ef1979 SHA-256: 2b6521cc8047e91db70ff2bc021301ebae8a100f54b4d1c904a7bb484dc6f2ce
494 Risk Score

Heuristics 15

  • Equation Editor OLE object high CVE related OLE_EQUATION_EDITOR
    Embedded OLE object word/embeddings/oleObject1.bin contains the Equation Editor CLSID, the legacy component exploited by CVE-2017-11882, CVE-2018-0802, and CVE-2018-0798.
  • ClamAV: Doc.Malware.Valyria-10025240-0 critical CLAMAV_DETECTION
    ClamAV detected this file as malware: Doc.Malware.Valyria-10025240-0
  • VBA project inside OOXML medium 9 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • VBA property-stored shellcode loader critical OLE_VBA_PROPERTY_SHELLCODE_LOADER
    VBA auto-exec macro takes the address (VarPtr) of a byte buffer decoded from a document property, marks memory executable (VirtualProtect/VirtualAlloc), and transfers control through a callback API (e.g. SetTimer/EnumWindows). The payload is hidden in the document properties rather than the macro source — the SVCReady loader pattern, a native shellcode runner rather than a parser CVE.
    Matched line in script
        Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
                        Set fileSystemObject = VBA.CreateObject("Scripting.FileSystemObject")
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
            Set result = VBA.GetObject("LDAP://" & adUserName)
  • CallByName call high OLE_VBA_CALLBYNAME
    CallByName call
    Matched line in script
                    CallByName( _
  • VBA polls global keyboard state (keylogger) high OLE_VBA_KEYLOGGER_SPYWARE
    The macro declares or calls a Win32 keystroke-monitoring API (GetAsyncKeyState, SetWindowsHookEx WH_KEYBOARD, or GetKeyboardState) to capture keystrokes system-wide. No legitimate document automation polls global key state; this is the core of a VBA keylogger, usually paired with active-window capture (GetForegroundWindow) and a log file. A high-confidence spyware behaviour independent of any download / Shell evidence.
    Matched line in script
    ' Konstanten für Tastaturfunktionen wie z. B. GetAsyncKeyState() / eWorksVBA.IsKeyPressed()
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Triggers on the COMBINATION of two tokens co-occurring in the same compiled VBA/cache stream: an auto-execution entry point (Auto_Open / AutoOpen / Document_Open / Workbook_Open / Auto_Close / AutoClose) AND a shell/download/object-execution token (Shell, CreateObject, GetObject, PowerShell, cmd.exe, URLDownloadToFile, WinHttp, XMLHTTP, ADODB.Stream, ShellExecute, ExecuteExcel4Macro). Neither token alone fires it — it is the pairing that flags p-code-only or source-extraction-failure macro documents where the visible VBA source is unavailable. The matched tokens are named in the detail line below.
  • AutoOpen macro low OLE_VBA_AUTOOPEN
    AutoOpen macro
    Matched line in script
    Sub AutoOpen()
  • Auto_Close macro low OLE_VBA_AUTOCLOSE
    Auto_Close macro
    Matched line in script
    Sub AutoClose()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        fallBackFolderName = Environ("UserProfile") & "\Desktop\"
  • Embedded OLE object medium OOXML_OLE_OBJECT
    Document contains an embedded OLE object
  • External hyperlinks (18) low OOXML_EXTERNAL_HYPERLINKS
    Document contains 18 external hyperlinks — clickable URLs are stored as external relationships. First target: http://www.dict.cc/englisch-deutsch/gloss.html
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://www.holzhauer-pumpen.de Document hyperlink
    • http://www.dict.cc/englisch-deutsch/gloss.htmlDocument hyperlink
    • http://www.dict.cc/englisch-deutsch/resin.htmlDocument hyperlink
    • http://www.dict.cc/englisch-deutsch/epoxy.htmlDocument hyperlink
    • http://www.dict.cc/englisch-deutsch/primer.htmlDocument hyperlink
    • http://www.dict.cc/englisch-deutsch/level.htmlDocument hyperlink
    • http://www.dict.cc/englisch-deutsch/zinc.htmlDocument hyperlink
    • http://de.wikipedia.org/wiki/OrdnungsrelationIn document text (OOXML body / shared strings)
    • http://msdn.microsoft.com/de-de/library/system.icomparable(v=vs.80).aspxIn document text (OOXML body / shared strings)
    • http://php.net/manual/de/function.usort.phpIn document text (OOXML body / shared strings)
    • http://msdn.microsoft.com/en-us/library/windows/desktop/dd375731(v=vs.85).aspxIn document text (OOXML body / shared strings)
    • http://de.wikipedia.org/wiki/Microsoft_OutlookIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/2006/relationships/imageIn document text (OOXML body / shared strings)
    • http://schemas.openxmlformats.org/officeDocument/200rU�In document text (OOXML body / shared strings)
    • http://php.net/manual/de/function.usort.php)�In document text (OOXML body / shared strings)

Extracted artifacts 3

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 1303996 bytes
SHA-256: 9cfd7f2eebf910b5cafe26706625ee2eeadd893faf23b318267a5fe072bd863d
Preview script
First 1,000 lines of the extracted script
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
Sub InsertAutotext(ByVal control As IRibbonControl)
   ' Inserts the specified text at the beginning of a range or selection.
   Dim Count As Integer
   Dim MyApplication As Application
   Dim MyRange As Range
   Dim MyTemplates As templates
   Dim MyTemplate As Template
   Dim MyBBEntries As BuildingBlockEntries
   Dim MyCurrentEntry As BuildingBlock
   Set MyApplication = ActiveDocument.Application
   Set MyRange = MyApplication.Selection.Range
   Set MyTemplates = MyApplication.templates
   For Count = 1 To MyTemplates.Count
        If MyTemplates.Item(Count).name = "hopu.dotm" Then
            Set MyTemplate = MyTemplates(Count)
            Exit For
        End If
   Next
   If MyTemplate Is Nothing Then
        Set MyTemplate = MyTemplates(1)
   End If
   Set MyBBEntries = MyTemplate.BuildingBlockEntries
   Set MyCurrentEntry = MyBBEntries.Item(control.Tag)
   MyCurrentEntry.Insert MyRange
End Sub



Sub WriteBuildingBlockList(ByVal control As IRibbonControl)
   Dim Count As Integer
   Dim MyApplication As Application
   Dim MyRange As Range
   Dim MyTemplates As templates
   Dim MyBBEntries As BuildingBlockEntries
   Set MyApplication = ActiveDocument.Application
   Set MyRange = MyApplication.Selection.Range
   Set MyTemplates = MyApplication.templates
   Set MyTemplate = MyTemplates.Item(1)
   Set MyBBEntries = MyTemplate.BuildingBlockEntries
   For Count = 1 To MyBBEntries.Count
        MyRange.InsertAfter (MyBBEntries.Item(Count).name)
        MyRange.InsertAfter (vbNewLine)
   Next
End Sub



Public Sub CustomAddresseEinfügen(ByVal control As IRibbonControl)
    replaceAddress Word.Application.ActiveDocument, True, True
End Sub



Public Sub CustomSpeichereDokumentUndZähleHoch(ByVal control As IRibbonControl)
    Dim f As File
    Dim fol As Folder
    Dim fso As fileSystemObject
    Dim f_max As File
    Dim doc_number As Integer
    Dim doc_prefix As String
    Dim doc_template As String
    Dim doc_newname As String
    
    On Error GoTo ErrHandle
    
    doc_prefix = LCase(GetNTUserName)
    If doc_prefix = vbNullString Then
        MsgBox "Fehler beim Ermitteln des Benutzernamens!", vbExclamation, "Fehler"
        Exit Sub
    End If
    Set fso = New fileSystemObject
    If fso.FolderExists(DEFAULT_SAVEDIRECTORY) Then
        Set fol = fso.GetFolder(DEFAULT_SAVEDIRECTORY)
        For Each f In fol.files
            If LCase(Mid(f.name, 1, Len(doc_prefix))) = doc_prefix And _
               LCase(Mid(f.name, Len(f.name) - Len(DOCUMENT_SUFFIX) + 1, Len(DOCUMENT_SUFFIX))) = DOCUMENT_SUFFIX Then
                If f_max Is Nothing Then
                    Set f_max = f
                End If
                If f.name > f_max.name And GetDocumentNumber(f.name, doc_number) Then
                    Set f_max = f
                End If
            End If
        Next
        If f_max Is Nothing Then
            ' Noch keine Dokumente für diesen Benutzer angelegt
            doc_number = 1
        Else
            If GetDocumentNumber(f_max.name, doc_number) Then
                ' Gleichzeitiger Zugriff
                Do Until Not fso.FileExists(DEFAULT_SAVEDIRECTORY & "\" & doc_prefix & doc_number & "." & DOCUMENT_SUFFIX)
                    ' Schon vorhanden ...
                    doc_number = doc_number + 1
                Loop
            Else
                ' Irgendein Fehler aufgetreten
                MsgBox "Ein Fehler ist beim Ermitteln der höchsten Dokumentnummer aufgetreten. " & _
                       "Der Dateiname " & f_max.name & " enthält keine gültige Indizierung!" & vbCrLf & vbCrLf & _
                       "ACHTUNG : Es wird mit dem Index 1 fortgefahren!", vbExclamation, "Fehler"
            End If
        End If
        
        doc_template = ActiveDocument.name
        
        ' Speichern
        doc_newname = DEFAULT_SAVEDIRECTORY & doc_prefix & doc_number & "." & DOCUMENT_SUFFIX
        ActiveDocument.SaveAs doc_newname, _
                      FileFormat:=wdFormatDocument, _
                      LockComments:=False, _
                      Password:="", _
                      AddToRecentFiles:=False, _
                      WritePassword:="", _
                      ReadOnlyRecommended:=False, _
                      EmbedTrueTypeFonts:=False, _
                      SaveNativePictureFormat:=False, _
                      SaveFormsData:=False, _
                      SaveAsAOCELetter:=False
                                      
        ' Vorlage schliessen
        On Error Resume Next
        Documents(doc_template).Close wdDoNotSaveChanges
        ' Neues Dokument aktivieren
        Documents(doc_newname).ActiveWindow.Activate
    Else
        MsgBox "Der Ordner " & DEFAULT_SAVEDIRECTORY & " zum Speichern des Dokumentes ist nicht vorhanden!", _
               vbExclamation, "Fehler beim Zugriff auf den Dokumentenordner"
    End If
        
ExitHandle:
    Exit Sub
    
ErrHandle:
    MsgBox "Ein Fehler ist beim Speichern des aktuellen Dokumentes '" & doc_newname & "' aufgetreten. " & _
           "Die Fehlerbeschreibung lautet : " & Err.Description, vbExclamation, "Fehler beim Speichern!"
End Sub



Public Sub CustomDruckeArbeitsplatz(ByVal control As IRibbonControl)
    SetPrinterByWordBasic defaultprinter
    SetPrinterTray
    ActiveDocument.PrintOut
End Sub



Public Sub CustomDruckeAufAnderenDrucker(ByVal control As IRibbonControl)
    Load Form_SelectPrinter
    Form_SelectPrinter.Show
    SetPrinterByWordBasic defaultprinter
End Sub



Sub CustomDurchschlägeDruckenBriefe(ByVal control As IRibbonControl)
    If checkForCompanyPrinterTray Then
        DurchschlägeDrucken PAPER_GESCHAEFT, PAPER_DEFAULT, PAPER_DEFAULT, PAPER_DEFAULT
    Else
        MsgBox "Das Dokument kann nicht auf Firmenpapier gedruckt werden! " & vbCrLf & _
               "Bitte verwenden Sie ein anderes Druck-Symbol!", vbInformation, DIALOGTITLE_ERROR
    End If
End Sub




Sub CustomDurchschlägeDruckenRechnungen(ByVal control As IRibbonControl)
 
 Dim i As Byte
 Dim Papiersorte As TPrintPaper

 ' Standarddrucker setzen
 SetPrinterByWordBasic defaultprinter
 
 Selection.HomeKey Unit:=wdStory
 Selection.Font.name = "LettrGoth12 BT"
 Selection.Font.Size = 12
 Selection.Font.Bold = True

 For i = 1 To 3

  Select Case i
   ' ORIGINALAUSDRUCK
   Case 1:
     Selection.InsertAfter " "
     Papiersorte = PAPER_GESCHAEFT

    'ERSTE KOPIE -GELB-
   Case 2:
     Selection.Cut
     Selection.InsertAfter "1. Kopie  -GELB-"
     Papiersorte = PAPER_DEFAULT

    'ZWEITE KOPIE -ROT-
   Case 3:
     Selection.Cut
     Selection.InsertAfter "2. Kopie  -ROT-"
     Papiersorte = PAPER_DEFAULT

  End Select
    
    ' Ausdruck mit gewählten Einstellungen
    SetPrinterTray Papiersorte
    ActiveDocument.PrintOut

 Next i
 ' Eingefügten Text löschen
 Selection.Cut
 
End Sub



Sub CustomDurchschlägeDruckenFaxeUndNormalpapier(ByVal control As IRibbonControl)
    DurchschlägeDrucken PAPER_DEFAULT, PAPER_DEFAULT, PAPER_DEFAULT, PAPER_DEFAULT
End Sub




Private Function GetDocumentNumber(fileName As String, _
                                   ByRef Document_Index As Integer) As Boolean
    Dim i As Integer
    Dim start_nummer As Integer
    Dim stop_nummer As Integer
    Dim c As String
    
    On Error GoTo ErrHandle
    start_nummer = -1
    stop_nummer = -1
    For i = 1 To Len(fileName)
        c = Mid(fileName, i, 1)
        If IsNumeric(c) Then
            ' Nummer beginnt hier
            start_nummer = i
            Exit For
        End If
    Next
    For i = Len(fileName) To 1 Step -1
        c = Mid(fileName, i, 1)
        If c = "." Then
            ' Erster Punkt von rechts ist Ende von Nummer
            stop_nummer = i
            Exit For
        End If
    Next
    If start_nummer <> -1 And stop_nummer <> -1 And stop_nummer > start_nummer Then
        Document_Index = CInt(Mid(fileName, start_nummer, (stop_nummer - start_nummer)))
        GetDocumentNumber = True
    Else
        Document_Index = 1
        GetDocumentNumber = False
    End If
    Exit Function
    
ErrHandle:
    GetDocumentNumber = False
End Function

Attribute VB_Name = "Form_InsertAddress"
Attribute VB_Base = "0{B1DB96BE-2D7B-4ADE-B5B2-1D554ADF4B0E}{3757519C-4A42-4C2E-9F47-7AD6529EA33A}"
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{A50F87F2-0C14-49ED-A53F-6C958EB1CF4C}{24561428-0DCE-441A-8479-AEF72D36F571}"
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{DD23CD78-894D-4F28-B973-71083F3583D0}{2E783375-064E-4553-AA58-AD1A5C492C8B}"
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
…
ooxml_oleobject_00.bin ooxml-ole-object OOXML embedded OLE part: word/embeddings/oleObject1.bin 3072 bytes
SHA-256: 622b621cb0a3aece33a0db0c13baac6c3870989c2e987d991a2a7512ec039e67
vbaProject_00.bin vba-project OOXML VBA project: word/vbaProject.bin 4771840 bytes
SHA-256: 7430cb258450006b88153135fe0621a88066a6b6eea0c2729a2dcb99f070decd
Detection
ClamAV: Doc.Malware.Valyria-10025240-0
Obfuscation or payload: unlikely

Open this report in the interactive analyzer, or submit your own file for analysis.