Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 80b5d22a47f0e934…

MALICIOUS

Office (OOXML)

1.54 MB Created: 2018-09-25 08:53:00 UTC Authoring application: Microsoft Office Word 16.0000 First seen: 2021-07-07
MD5: 655ae9004aa63f0139b666857c2e4310 SHA-1: e65095cf93ee4559c11134c38220d7ea3b23eccd SHA-256: 80b5d22a47f0e934d0d14ae9b81db0ff6ab3118507b8619928d7e6f15167305d
130 Risk Score

Malware Insights

MITRE ATT&CK
T1203 Exploitation for Client Execution T1059.005 Visual Basic

The presence of an Equation Editor OLE object and VBA macros with auto-execution tokens strongly suggests exploitation of a known vulnerability (CVE-2017-11882) to gain execution. The VBA macro, though truncated, appears to be designed to interact with templates and potentially download additional content, indicating a downloader or dropper functionality. The URL http://www.gmayor.com/installing_macro.htm was found embedded, which could be a secondary payload source or a lure.

Heuristics 6

  • 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.
  • VBA project inside OOXML medium 1 related finding OOXML_VBA
    Document contains a VBA project — VBA macros present
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Compiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
  • 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.gmayor.com/installing_macro.htmIn document text (OOXML body / shared strings)
    • http://www.w3.org/1999/02/22-rdf-syntax-ns#In document text (OOXML body / shared strings)
    • http://ns.adobe.com/xap/1.0/mm/In document text (OOXML body / shared strings)
    • http://ns.adobe.com/xap/1.0/sType/ResourceRef#In document text (OOXML body / shared strings)
    • http://ns.adobe.com/xap/1.0/In document text (OOXML body / shared strings)
    • http://purl.org/dc/elements/1.1/In document text (OOXML body / shared strings)
    • 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

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) 20512 bytes
SHA-256: 39b0a81c050ee994d0bff5a19f4ad1755d6fc347a358bc885592619dcf6b5b27
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

 Selection.InsertAfter " "
 Papiersorte = PAPER_GESCHAEFT
    
 ' Ausdruck mit gewählten Einstellungen
 SetPrinterTray Papiersorte
 ActiveDocument.PrintOut
 ' Eingefügten Text löschen
 Selection.Cut

End Sub

' *****************************************************************************************
' * Doings                 : Druckt drei Kopien, davon das erste auf Firmenpapier
' *
' * Author                 : ANDREAS SCHÄFER
' * Written                : 21.08.2003
' *****************************************************************************************
Sub customDurchschlägeDruckenRechnungenAlt(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

Public Sub CustomDurchschlägePDFRechnungen(ByVal control As IRibbonControl)
' Public Sub CustomDurchschlägePDFRechnungen()

 Dim Papiersorte As TPrintPaper
 Dim rnrEingabe As String
 Dim pfadMitKopie As String
 Dim pfadOhneKopie As String
 
 pfadMitKopie = "P:\Buchhaltung\Rechnungsbearbeitung\Rechnungsausgang\"
 pfadOhneKopie = "P:\Buchhaltung\Ausgangsrechnungen\"
 
 rnrEingabe = InputBox("Bitte Rechnungsnummer eingeben:", "PDF-Export: Rechnungsnummer eingeben")
 
 If rnrEingabe = "" Then
   MsgBox "Keine Rechnungsnummer eingegeben!" & Chr(10) & "PDF / Rechnung wird abgebrochen!"
   Exit Sub
 End If
 
 ' Standarddrucker setzen
 SetPrinterByWordBasic defaultprinter
 
 Selection.HomeKey Unit:=wdStory
 Selection.Font.name = "LettrGoth12 BT"
 Selection.Font.Size = 12
 Selection.Font.Bold = True

 Selection.InsertAfter " "
 Papiersorte = PAPER_DEFAULT

 ' Erster Export Briefpapier MIT Kopie
 WasserzeichenBriefpapierSetzenMitKopie
 TextfeldKontierungEinblenden
 KontierungSetzen
 pdfExport rnrEingabe, pfadMitKopie, False
 TextfeldKontierungAusblenden
 WasserzeichenBriefpapierEntfernenMitKopie

 ' Zweiter Export Briefpapier OHNE Kopie
 WasserzeichenBriefpapierSetzenOhneKopie
 pdfExport rnrEingabe, pfadOhneKopie, True
 WasserzeichenBriefpapierEntfernenOhneKopie

End Sub
Public Sub pdfExport(dateiname As String, pfad As String, r As Boolean)

ActiveDocument.Fields.Update

Dim savePath As String
Dim errTextpdfExport As String

errTextpdfExport = "Mindestens eine der beiden PDF Dateien wurde nicht korrekt erstellt!" & Chr(10) & "Bitte kontaktieren Sie Ihren Administrator!"

On Error GoTo ErrHandle

 If r = False Then
   savePath = pfad & dateiname & ".pdf"
   ActiveDocument.ExportAsFixedFormat outputfilename:=savePath, exportformat:=wdExportFormatPDF
   MsgBox "Dokument gespeichert unter " & savePath
   Exit Sub
 End If
 
 If r = True Then
   savePath = pfad & "R" & dateiname & ".pdf"
   ActiveDocument.ExportAsFixedFormat outputfilename:=savePath, exportformat:=wdExportFormatPDF
   MsgBox "Dokument gespeichert unter " & savePath
   Exit Sub
 End If

ErrHandle:
MsgBox errTextpdfExport
Exit Sub

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

Sub WasserzeichenBriefpapierSetzenMitKopie()

briefpapier = "P:\EDV-Vorlagen für alle Programme\09-Verwaltung\Briefpapier für PDF-RG-Druck\BriefpapierMitKopie.png"
picbrightness = 0.85
piccontrast = 0.65
picheight = 28.43
picwidth = 19
picdistancetop = 0
piclockratio = False

    ActiveDocument.Sections(1).Range.Select
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
    Selection.HeaderFooter.Shapes.AddPicture(fileName:= _
        briefpapier, LinkToFile:=False, _
        SaveWithDocument:=True).Select
    Selection.ShapeRange.name = "WordWatermark20201123first"
    ' Selection.ShapeRange.PictureFormat.Brightness = picbrightness
    ' Selection.ShapeRange.PictureFormat.Contrast = piccontrast
    Selection.ShapeRange.LockAspectRatio = piclockratio
    Selection.ShapeRange.Height = CentimetersToPoints(picheight)
    Selection.ShapeRange.Width = CentimetersToPoints(picwidth)
    Selection.ShapeRange.WrapFormat.DistanceTop = CentimetersToPoints(1.27)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
'    Selection.ShapeRange.RelativeHorizontalPosition = _
'        wdRelativeVerticalPositionMargin
'    Selection.ShapeRange.RelativeVerticalPosition = _
'        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
'    Selection.ShapeRange.Top = wdShapeCenter
'    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    ActiveDocument.Sections(1).Range.Select
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddPicture(fileName:= _
        briefpapier, LinkToFile:=False, _
        SaveWithDocument:=True).Select
    Selection.ShapeRange.name = "WordWatermark20201123next"
    ' Selection.ShapeRange.PictureFormat.Brightness = picbrightness
    ' Selection.ShapeRange.PictureFormat.Contrast = piccontrast
    Selection.ShapeRange.LockAspectRatio = piclockratio
    Selection.ShapeRange.Height = CentimetersToPoints(picheight)
    Selection.ShapeRange.Width = CentimetersToPoints(picwidth)
    Selection.ShapeRange.WrapFormat.DistanceTop = CentimetersToPoints(picdistancetop)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
'    Selection.ShapeRange.RelativeHorizontalPosition = _
'        wdRelativeVerticalPositionMargin
'    Selection.ShapeRange.RelativeVerticalPosition = _
'        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
'    Selection.ShapeRange.Top = wdShapeCenter
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Sub WasserzeichenBriefpapierSetzenOhneKopie()

briefpapier = "P:\EDV-Vorlagen für alle Programme\09-Verwaltung\Briefpapier für PDF-RG-Druck\BriefpapierOhneKopie.png"
picbrightness = 0.85
piccontrast = 0.65
picheight = 28.43
picwidth = 19
picdistancetop = 0
piclockratio = False

    ActiveDocument.Sections(1).Range.Select
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
    Selection.HeaderFooter.Shapes.AddPicture(fileName:= _
        briefpapier, LinkToFile:=False, _
        SaveWithDocument:=True).Select
    Selection.ShapeRange.name = "WordWatermark20201123first"
    ' Selection.ShapeRange.PictureFormat.Brightness = picbrightness
    ' Selection.ShapeRange.PictureFormat.Contrast = piccontrast
    Selection.ShapeRange.LockAspectRatio = piclockratio
    Selection.ShapeRange.Height = CentimetersToPoints(picheight)
    Selection.ShapeRange.Width = CentimetersToPoints(picwidth)
    Selection.ShapeRange.WrapFormat.DistanceTop = CentimetersToPoints(1.27)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
'    Selection.ShapeRange.RelativeHorizontalPosition = _
'        wdRelativeVerticalPositionMargin
'    Selection.ShapeRange.RelativeVerticalPosition = _
'        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
'    Selection.ShapeRange.Top = wdShapeCenter
'    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    ActiveDocument.Sections(1).Range.Select
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddPicture(fileName:= _
        briefpapier, LinkToFile:=False, _
        SaveWithDocument:=True).Select
    Selection.ShapeRange.name = "WordWatermark20201123next"
    ' Selection.ShapeRange.PictureFormat.Brightness = picbrightness
    ' Selection.ShapeRange.PictureFormat.Contrast = piccontrast
    Selection.ShapeRange.LockAspectRatio = piclockratio
    Selection.ShapeRange.Height = CentimetersToPoints(picheight)
    Selection.ShapeRange.Width = CentimetersToPoints(picwidth)
    Selection.ShapeRange.WrapFormat.DistanceTop = CentimetersToPoints(picdistancetop)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
'    Selection.ShapeRange.RelativeHorizontalPosition = _
'        wdRelativeVerticalPositionMargin
'    Selection.ShapeRange.RelativeVerticalPosition = _
'        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
'    Selection.ShapeRange.Top = wdShapeCenter
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Sub WasserzeichenBriefpapierEntfernenMitKopie()
    ActiveDocument.Sections(1).Range.Select
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
    Selection.HeaderFooter.Shapes("WordWatermark20201123first").Select
    Selection.Delete
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes("WordWatermark20201123next").Select
    Selection.Delete
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Sub WasserzeichenBriefpapierEntfernenOhneKopie()
    ActiveDocument.Sections(1).Range.Select
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekFirstPageHeader
    Selection.HeaderFooter.Shapes("WordWatermark20201123first").Select
    Selection.Delete
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes("WordWatermark20201123next").Select
    Selection.Delete
    ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Sub KontierungSetzen()
    ' ActiveDocument.Shapes("Textfeld 2").Select
    ' Selection.ShapeRange.Select
    
    Dim strKontierung As String

    strKontierung = InputBox("Bitte Kontierung eingeben:", "PDF-Export: Kontierung eingeben")
 
    If strKontierung = "" Then
        MsgBox "Keine Kontierung eingegeben!" & Chr(10) & "PDF / Rechnung wird abgebrochen!"
        Exit Sub
    End If
    
    ' ActiveDocument.Variables("E-Mail").Value = dvEMail
    ' ActiveDocument.Variables.Item("kontierung").Value = ""
    ActiveDocument.Variables.Item("kontierung").Value = strKontierung
    
    UpdateAllDocVariable
    ActiveDocument.Fields.Update
    
End Sub

Sub TextfeldKontierungAusblenden()
    ActiveDocument.Shapes("Textfeld 2").Select
    Selection.WholeStory
    With Selection.Font
        .Hidden = True
    End With
End Sub

Sub TextfeldKontierungEinblenden()
    ActiveDocument.Shapes("Textfeld 2").Select
    Selection.WholeStory
    With Selection.Font
        .Hidden = False
    End With
End Sub

Sub UpdateAllDocVariable()

'   Update all DocVariable fields in a document, even if in headers/footers or textboxes

'   Based on code at http://www.gmayor.com/installing_macro.htm
'   Charles Kenyon
'   18 October 2018
'
    Dim oStory As Range
    Dim oField As Field
    '
    For Each oStory In ActiveDocument.StoryRanges
        For Each oField In oStory.Fields
            If oField.Type = wdFieldDocVariable Then oField.Update
        Next oField
        '
        If oStory.StoryType <> wdMainTextStory Then
            While Not (oStory.NextStoryRange Is Nothing)
            Set oStory = oStory.NextStoryRange
                For Each oField In oStory.Fields
                    If oField.Type = wdFieldDocVariable Then oField.Update
                Next oField
            Wend
        End If
        '
    Next oStory
    '
    Set oStory = Nothing
    Set oField = Nothing
End Sub
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 732672 bytes
SHA-256: d9b0e1bf9dd6d7a4688f9db760a55ae89706152cccb3384a30e188d93ff36e7c

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