Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 bd32a3836492b312…

MALICIOUS

Office (OOXML)

581.4 KB Created: 2015-05-02 09:49:53 UTC Authoring application: Microsoft Excel 16.0300 First seen: 2021-06-28
MD5: 8deff7abcdc8b4c49bede97563686fa1 SHA-1: 76e83b4dd3fdeba52d238897ce546696258fa94b SHA-256: bd32a3836492b3125c1c8f134fbcae55538f00d906e9d131fc29476d1922f13b
278 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1071.001 Web Protocols T1059 Command and Scripting Interpreter

The sample is an Excel document containing a Workbook_Open VBA macro. This macro utilizes URLDownloadToFile to download a file from http://www.mediaconn.de/test/test.txt and then executes it using the Shell() function. This indicates a downloader or droppper functionality, aiming to fetch and run a secondary payload.

Heuristics 9

  • VBA project inside OOXML medium 7 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Potential Shell call in VBA critical OLE_VBA_SHELL
    Potential Shell call in VBA
    Matched line in script
            Unload Me
        varShellWindow = Shell(strCopyLocal, vbNormalFocus)
        AppActivate varShellWindow
  • URLDownloadToFile in VBA critical OLE_VBA_DOWNLOAD
    URLDownloadToFile in VBA
    Matched line in script
    #If VBA7 Then '64Bit Kompatibel Office 2010 und Neuer
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" ( _
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        strBuffer = ""
    Set objRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
    objRequest.Open "GET", sURL, False
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
        localHost = "." 'Technically could be run against remote computers, if allowed
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & localHost & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
  • 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.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
    On Error GoTo HandleErr
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
            Application.ScreenUpdating = True
        strPDFPath = Environ("Temp") & "\" & ThisWorkbook.Name & ".pdf"
        ThisWorkbook.ExportAsFixedFormat xlTypePDF, strPDFPath, xlQualityStandard, True, False, , , True
  • 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.RibbonCreator2010.com Referenced by macro
    • http://www.RibbonCreator2010.deReferenced by macro
    • http://www.ribboncreator2010.comReferenced by macro
    • http://www.ribboncreator.comReferenced by macro
    • http://www.accessribon.comReferenced by macro
    • http://www.avenius.comReferenced by macro
    • http://www.accessribbon.de/index.php?Downloads:12Referenced by macro
    • http://www.mediaconn.de/test/test.txtReferenced by macro
    • http://schemas.microsoft.com/office/2009/07/customuiReferenced by macro
    • http://ns.adobe.com/xap/1.0/Referenced by macro
    • http://www.w3.org/1999/02/22-rdf-syntax-ns#Referenced by macro
    • http://purl.org/dc/elements/1.1/Referenced by macro

Extracted artifacts 2

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 101137 bytes
SHA-256: b00e6c315d1c3abe4a8fabb38dca4f685c77d83cf09c101b3a8a9a79e437afda
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "DieseArbeitsmappe"
Attribute VB_Base = "0{00020819-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
Option Explicit

'****************************************************************************
'***    Erstellt durch:                                                   ***
'***    Fa. Mediaconn Soft- und Hardwarelösungen                          ***
'***    Mozartstr. 18                                                        ***
'***    78570 Mühlheim-Stetten                                                  ***
'***    Bearbeiter: Bernd Grathwohl                                       ***
'****************************************************************************

Private Sub Workbook_Open()
    On Error GoTo HandleErr
    
    Copyright.Show
    Call GanzeBreite
    Call GoPos1
    'Worksheets("Gruppe1").ScrollArea = "a1:bz250"
    With Application
        .OnKey "{F2}", ""
        .OnKey "{F3}", "Erweitern"
        .OnKey "{F4}", "Selectioncheck"
        .OnKey "{F5}", "Zoom1"
        .OnKey "{F6}", "Zoom2"
        .OnKey "{F7}", "Zoom3"
        .OnKey "{F8}", "GanzeBreite"
        .OnKey "{F10}", ""
        .OnKey "{F11}", ""
        .OnKey "{Home}", "GoPos1"
        .OnKey "{End}", "Ende"
        .DefaultSaveFormat = xlOpenXMLWorkbookMacroEnabled
    End With
    ActiveSheet.EnableSelection = xlUnlockedCells
    Call Startjahr
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 04-20-2004 17:45:36 'ErrorHandler:$$D=04-20-2004    'ErrorHandler:$$T=17:45:36
HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "DieseArbeitsmappe.Workbook_Open"   'ErrorHandler:$$N=DieseArbeitsmappe.Workbook_Open
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub

Private Sub Workbook_Activate()
    'Symbolleisten merken und ausblenden
    On Error GoTo HandleErr
    Call Arbeitsumgebung
    Worksheets("Gruppe1").Activate 'notwendig, um F-Tastenfunktionen wiederherzustellen
    With Application
        .OnKey "{F2}", ""
        .OnKey "{F3}", "Erweitern"
        .OnKey "{F4}", "Selectioncheck"
        .OnKey "{F5}", "Zoom1"
        .OnKey "{F6}", "Zoom2"
        .OnKey "{F7}", "Zoom3"
        .OnKey "{F8}", "GanzeBreite"
        .OnKey "{F10}", ""
        .OnKey "{F11}", ""
        .OnKey "{Home}", "GoPos1"
        .OnKey "{End}", "Ende"
        .OnKey "+^{f}", "Blattfreigabe"
        .OnKey "+^{s}", "Blattschutz"
        .OnKey "+^{d}", "Diagrammschutz"
    End With
    ActiveSheet.EnableSelection = xlUnlockedCells
    'ActiveSheet.PageSetup.PrintArea = gconDruckbereich
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-25-2002 17:36:32 'ErrorHandler:$$D=05-25-2002    'ErrorHandler:$$T=17:36:32
HandleErr:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "DieseArbeitsmappe.Workbook_Activate"   'ErrorHandler:$$N=DieseArbeitsmappe.Workbook_Activate
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) 'Für Sortierung
    On Error GoTo Workbook_SheetBeforeDoubleClick_Error
    Select Case Target.Address
    Case "$A$4" 'Sortieren nach Nr
        Cancel = True
        With ActiveSheet
            Call Freigabeblatt
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            .Range("A3").Select
            .Range(.Cells(5, 1), .Cells(lngEndZeileKind, .UsedRange.Columns.Count)).Sort Key1:=Range("A5"), _
            Order1:=xlAscending, Key2:=Range("B5"), Order2:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'sortieren der Fehler
            Call SchutzBlatt
            .Range("A4").Value = "Nr.  " & ChrW(CLng("&H" & "2191")) 'Pfeil
            .Range("B4").Value = "Name des Kindes"
            .Range("C4").Value = "Geburtsdatum"
            .Range("D4").Value = "Betr. Form"
            .Range("E4").Value = "Vertrag"
            .Range("A3").Select
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
        End With
    Case "$B$4" 'Sortieren nach Name
        Cancel = True
        With ActiveSheet
            Call Freigabeblatt
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            .Range("A3").Select
            .Range(.Cells(5, 1), .Cells(lngEndZeileKind, .UsedRange.Columns.Count)).Sort Key1:=Range("B5"), _
            Order1:=xlAscending, Key2:=Range("C5"), Order2:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'sortieren der Fehler
            Call SchutzBlatt
            .Range("A4").Value = "Nr."
            .Range("B4").Value = "Name des Kindes  " & ChrW(CLng("&H" & "2191")) 'Pfeil
            .Range("C4").Value = "Geburtsdatum"
            .Range("D4").Value = "Betr. Form"
            .Range("E4").Value = "Vertrag"
            .Range("A3").Select
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
        End With
    Case "$C$4" 'Sortieren nach Geburtsdatum
        Cancel = True
        With ActiveSheet
            Call Freigabeblatt
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            .Range("A3").Select
            .Range(.Cells(5, 1), .Cells(lngEndZeileKind, .UsedRange.Columns.Count)).Sort Key1:=Range("C5"), _
            Order1:=xlAscending, Key2:=Range("B5"), Order2:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'sortieren der Fehler
            Call SchutzBlatt
            .Range("A4").Value = "Nr."
            .Range("B4").Value = "Name des Kindes"
            .Range("C4").Value = "Geburtsdatum  " & ChrW(CLng("&H" & "2191")) 'Pfeil
            .Range("D4").Value = "Betr. Form"
            .Range("E4").Value = "Vertrag"
            .Range("A3").Select
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
        End With
    Case "$D$4" 'Sortieren nach Betreuungsform
        Cancel = True
        With ActiveSheet
            Call Freigabeblatt
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            .Range("A3").Select
            .Range(.Cells(5, 1), .Cells(lngEndZeileKind, .UsedRange.Columns.Count)).Sort Key1:=Range("D5"), _
            Order1:=xlAscending, Key2:=Range("A5"), Order2:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'sortieren der Fehler
            Call SchutzBlatt
            .Range("A4").Value = "Nr."
            .Range("B4").Value = "Name des Kindes"
            .Range("C4").Value = "Geburtsdatum"
            .Range("D4").Value = "Betr. Form  " & ChrW(CLng("&H" & "2191")) 'Pfeil
            .Range("E4").Value = "Vertrag"
            .Range("A3").Select
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
        End With
    Case "$E$4" 'Sortieren nach Vertrag
        Cancel = True
        With ActiveSheet
            Call Freigabeblatt
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            .Range("A3").Select
            .Range(.Cells(5, 1), .Cells(lngEndZeileKind, .UsedRange.Columns.Count)).Sort Key1:=Range("E5"), _
            Order1:=xlAscending, Key2:=Range("A5"), Order2:=xlAscending, Header:=xlNo, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom 'sortieren der Fehler
            Call SchutzBlatt
            .Range("A4").Value = "Nr."
            .Range("B4").Value = "Name des Kindes"
            .Range("C4").Value = "Geburtsdatum"
            .Range("D4").Value = "Betr. Form"
            .Range("E4").Value = "Vertrag  " & ChrW(CLng("&H" & "2191")) 'Pfeil
            .Range("A3").Select
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
        End With
    End Select
    
    On Error GoTo 0
    Exit Sub
Workbook_SheetBeforeDoubleClick_Error:
   Application.EnableEvents = True
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
   Select Case Err.Number
   Case Else
        Call SchutzBlatt
        MsgBox "Error " & Err.Number & " (" & Err.description & ") in procedure Workbook_SheetBeforeDoubleClick"
   End Select

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error GoTo HandleErr

    If Application.CutCopyMode = xlCut Then 'Ausschneiden verhindern
        MsgBox ("Ausschneiden nicht möglich")
        Application.CutCopyMode = False
        Exit Sub
    End If
    Application.EnableEvents = False
    Call SelectionCheck
    Application.EnableEvents = True
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-25-2002 17:36:32 'ErrorHandler:$$D=05-25-2002    'ErrorHandler:$$T=17:36:32
HandleErr:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "DieseArbeitsmappe.Workbook_SheetSelectionChange"   'ErrorHandler:$$N=DieseArbeitsmappe.Workbook_SheetSelectionChange
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo HandleErr

    With ActiveSheet
        Select Case Target.Address 'Kopfzeilen Schützen
        Case "$A$4"
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        Case "$B$4"
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        Case "$C$4"
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        Case "$D$4"
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        Case "$E$4"
            Application.EnableEvents = False
            Application.Undo
            Application.EnableEvents = True
        End Select
        If Target.Row = lngEndZeileKind And Target.Text <> "" Then 'Wenn 2 Reihen über Gruppe, neue Reihe einfügen
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            Call Freigabeblatt
'            .Rows(6).Copy'buggy in 2016
            .Rows(Target.Row + 1).Insert Shift:=xlDown
            .Rows(Target.Row).AutoFill .Rows(Target.Row & ":" & Target.Row + 1), xlFillFormats
'            Selection.ClearContents
            Selection.EntireRow.Hidden = False
            SchutzBlatt
            If Target.Column >= 4 Then 'in neue Zeile springen
                .Cells(Target.Row + 1, 1).Select
            Else 'in gleicher Zeile eine Spalte weiter (tab)
                .Cells(Target.Row, Target.Column + 1).Select
            End If
            Application.CutCopyMode = False
            Application.Calculation = xlCalculationAutomatic
            Application.EnableEvents = True
            Application.ScreenUpdating = True
        End If
    End With

    On Error GoTo 0
    Exit Sub

HandleErr:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Select Case Err.Number
         Case Else
              MsgBox "Fehler " & Err.Number & " (" & Err.description & ") in Prozedur Workbook_SheetChange von VBA Dokument DieseArbeitsmappe"
     End Select
End Sub

Private Sub Workbook_Deactivate()
    Call UndoUmgebung
    With Application
        .OnKey "{F2}", ""
        .OnKey "{F3}", ""
        .OnKey "{F4}", ""
        .OnKey "{F5}", ""
        .OnKey "{F6}", ""
        .OnKey "{F7}", ""
        .OnKey "{F8}", ""
        .OnKey "{F9}", ""
        .OnKey "{F10}", ""
        .OnKey "{Home}", ""
        .OnKey "{End}", ""
        .OnKey "+^{f}", ""
        .OnKey "+^{s}", ""
        .OnKey "+^{d}", ""
    End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim CountPersonal_XL As Integer
Dim oWB As Excel.Workbook
Dim intAntwort As Integer
    'Fehler Passwortabfrage beim schließen beseitigen
    If Not ThisWorkbook.Saved = True And Not gbolStartetclose = True Then
        gbolStartetclose = True
        Select Case MsgBox("Wollen Sie speichern vor dem Beenden?", vbYesNo Or vbQuestion Or vbDefaultButton1, "Bedarfsentwicklung")
            Case vbYes
                ThisWorkbook.Save
            Case vbNo
        End Select
    End If
    ThisWorkbook.Saved = True
    'Wenn kein weiteres Excel geöffnet, dann Excel ganz schließen. Beugt Fehler des doppelten öffnens vor
    For Each oWB In Workbooks
        If InStr(oWB.Name, "PERSONAL.XLS") > 0 Then
            CountPersonal_XL = 1
            Exit For
        End If
    Next
    Set oWB = Nothing
    'Set gobjRibbon = Nothing
    If Workbooks.Count - CountPersonal_XL = 1 Then
        Application.Quit
    End If
    End
End Sub

Private Sub Freigabeblatt()
    On Error GoTo HandleErr
    ActiveSheet.Unprotect "Offizier"
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-25-2002 17:36:32 'ErrorHandler:$$D=05-25-2002    'ErrorHandler:$$T=17:36:32
HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "Modul1.Freigabeblatt"  'ErrorHandler:$$N=Modul1.Freigabeblatt
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub

Private Sub SchutzBlatt()
    On Error GoTo HandleErr
    ActiveSheet.Protect Password:="Offizier", DrawingObjects:=False, contents:=True
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-25-2002 17:36:32 'ErrorHandler:$$D=05-25-2002    'ErrorHandler:$$T=17:36:32
HandleErr:
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "Modul1.SchutzBlatt"    'ErrorHandler:$$N=Modul1.SchutzBlatt
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub



Attribute VB_Name = "Tabelle1"
Attribute VB_Base = "0{00020820-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
Option Explicit

Private Sub Worksheet_Activate()
On Error GoTo HandleErr
    With Application
        .OnKey "{F2}", ""
        .OnKey "{F3}", "Erweitern"
        .OnKey "{F4}", "Selectioncheck"
        .OnKey "{F5}", "Zoom1"
        .OnKey "{F6}", "Zoom2"
        .OnKey "{F7}", "Zoom3"
        .OnKey "{F8}", "GanzeBreite"
        .OnKey "{F10}", ""
        .OnKey "{F11}", ""
        .OnKey "{Home}", "GoPos1"
        .OnKey "{End}", "Ende"
    End With
    ActiveSheet.EnableSelection = xlUnlockedCells
    'ActiveSheet.PageSetup.PrintArea = gconDruckbereich
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-25-2002 17:36:32 'ErrorHandler:$$D=05-25-2002    'ErrorHandler:$$T=17:36:32
HandleErr:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "Tabelle1.Worksheet_Activate"   'ErrorHandler:$$N=Tabelle1.Worksheet_Activate
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub



Attribute VB_Name = "Copyright"
Attribute VB_Base = "0{A27C2CB8-596A-4CCF-96C1-F1EE75FB418E}{0D78BAC5-CDB5-462A-89FC-0C2D3F1E481A}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit

Private Sub UserForm_Activate()
Dim varShellWindow As Variant
Dim strKiTaPersonalVersion As String

On Error GoTo HandleErr
    Me.lblDateiver.Caption = "Dateiversion: " & strdateiversion
    strKiTaPersonalVersion = GSGetSetting(HKEY_LOCAL_MACHINE, "Software\KiTaPersonal", "Version")
    Me.lblUpdate = ""
    If strKiTaPersonalVersion <> "" Then
        Me.lblKitaPersVer.Caption = "LV Kita Personal-Version: " & strKiTaPersonalVersion
        Me.lblUpdate = UpdateCheck
    Else
        Me.lblKitaPersVer.Caption = "Registrierungsdaten nicht vorhanden!"
        Me.lblUpdate = "Online Update nicht möglich"
    End If
    
    'And Len(strKiTaPersonalVersion) < 10
    Me.lblOfficeVer = "Excel Version: " & AppVer
    Me.lblWindowsVer = "Windows Version: " & getOperatingSystem 'Application.OperatingSystem
    If Me.lblUpdate = "Setup startet" Then
        Unload Me
        varShellWindow = Shell(strCopyLocal, vbNormalFocus)
        AppActivate varShellWindow
        AppActivate ThisWorkbook.Name
        ThisWorkbook.Close savechanges:=False
    End If
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-08-2004 11:18:23 'ErrorHandler:$$D=05-08-2004    'ErrorHandler:$$T=11:18:23
HandleErr:
    Select Case Err.Number
        Case Else
            'Err.Clear
            Resume Next
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub

Private Sub cmdProgrammstart_Click()
    Unload Me
End Sub

Private Sub cmdCancel_Click()
    'NoUndo = True
    Application.DisplayAlerts = False
    Unload Me
    ThisWorkbook.Close savechanges:=False
End Sub
    
Private Function AppVer() As String
    Dim str64Bit As String
    #If Win64 Then '64Bit Kompatibel Office 2010 und Neuer
        str64Bit = "64Bit"
    #Else
        str64Bit = "32Bit"
    #End If
    Select Case Val(Application.Version)
      Case 8
        AppVer = "Ver." & Application.Version & " (Excel 97) " & str64Bit
      Case 9
        AppVer = "Ver." & Application.Version & " (Excel 2000) " & str64Bit
      Case 10
        AppVer = "Ver." & Application.Version & " (Excel 2002/XP) " & str64Bit
      Case 11
        AppVer = "Ver." & Application.Version & " (Excel 2003) " & str64Bit
      Case 12
        AppVer = "Ver." & Application.Version & " (Excel 2007) " & str64Bit
      Case 14
        AppVer = "Ver." & Application.Version & " (Excel 2010) " & str64Bit
      Case 15
        AppVer = "Ver." & Application.Version & " (Excel 2013) " & str64Bit
      Case 16
        AppVer = "Ver." & Application.Version & " (Excel 2016) " & str64Bit
      Case Else
        AppVer = "Ver." & Application.Version & " (unbekannt) " & str64Bit
        Exit Function
    End Select
End Function

Public Function getOperatingSystem()
    Dim localHost       As String
    Dim objWMIService   As Variant
    Dim colOperatingSystems As Variant
    Dim objOperatingSystem As Variant
    On Error GoTo Error_Handler
    localHost = "." 'Technically could be run against remote computers, if allowed
    Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & localHost & "\root\cimv2")
    Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
    For Each objOperatingSystem In colOperatingSystems
        getOperatingSystem = objOperatingSystem.Caption & " " & objOperatingSystem.Version
        Exit Function
    Next
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: getOperatingSystem" & vbCrLf & _
           "Error Description: " & Err.description, _
           vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Attribute VB_Name = "modRegistry"
Option Explicit

'Konstanten für HKEY
Public Const HKEY_LOCAL_MACHINE = &H80000002

'übrige Konstanten
Private Const KEY_QUERY_VALUE = &H1
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Const KEY_READ = &H20019

'Deklarationen für API-Aufrufe
#If VBA7 Then '64Bit Kompatibel Office 2010 und Neuer

    Public Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _
        ByVal hKey As LongPtr, _
        ByVal lpSubKey As String, _
        ByVal ulOptions As Long, _
        ByVal samDesired As Long, _
        phkResult As LongPtr) As Long
    
    Public Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _
        ByVal hKey As LongPtr, _
        ByVal lpValueName As String, _
        ByVal lpReserved As LongPtr, _
        lpType As Long, _
        ByVal lpData As String, _
        lpcbData As Long) As Long
    
    Public Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _
        ByVal hKey As LongPtr) As Long

#Else ' Noch kein VBA7
    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
    
    Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
    ByVal samDesired As Long, phkResult As Long) As Long
    
    Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
    (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
    lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
#End If

Public Function GSGetSetting(hKey As Long, Section As String, Key As String) As Variant
    ' Gibt die unter Section\Key gespeicherten Daten zurück
    ' Wird der angegebene Pfad nicht gefunden, _
      so wird Empty (VarType() = Empty) zurückgegeben
    ' Es werden nur die Datentypen String (REG_SZ) und Long (REG_DWORD) gelesen _
      werden andere Datentypen erkannt, so wird Empty zurückgegeben.
    ' HKEY: HKEY_CLASSES_ROOT , HKEY_CURRENT_USER, _
     HKEY_LOCAL_MACHINE, HKEY_USERS

    Dim Ret As Long 'Rückgabewert der API Funktionen
    #If VBA7 Then
        Dim hKeyOpened As LongPtr 'Handle für den akt. geöffneten Key
    #Else
        Dim hKeyOpened As Long 'Handle für den akt. geöffneten Key
    #End If
    Dim Setting As Variant 'unter dem abgefragten Schlüssel gespeicherte Daten
    Dim BufferSize As Long
    Dim ValueType As Long
    Dim lngSetting As Long
    Dim strSetting As String

    Ret = RegOpenKeyEx(hKey, Section, 0, KEY_READ, hKeyOpened)

    If Ret = 0 Then
        ' Typ und Länge des Eintrages ermitteln
        Ret = RegQueryValueEx(hKeyOpened, Key, 0&, ValueType, 0&, BufferSize)
        'Speicherplatz reservieren
        strSetting = String$(BufferSize, 0)
        Ret = RegQueryValueEx(hKeyOpened, Key, 0&, ValueType, strSetting, BufferSize)
        If Ret = 0 Then
            If BufferSize > 0 Then
                Setting = Left$(strSetting, BufferSize - 1)
            Else
                Setting = ""
            End If
        End If
        GSGetSetting = Setting
        RegCloseKey (hKeyOpened)
    End If
End Function


Attribute VB_Name = "Tabelle8"
Attribute VB_Base = "0{00020820-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
Option Explicit

Private Sub Worksheet_Activate()
On Error GoTo HandleErr
    With Application
        .OnKey "{F2}", ""
        .OnKey "{F3}", "Erweitern"
        .OnKey "{F4}", "Selectioncheck"
        .OnKey "{F5}", "Zoom1"
        .OnKey "{F6}", "Zoom2"
        .OnKey "{F7}", "Zoom3"
        .OnKey "{F8}", "GanzeBreite"
        .OnKey "{F10}", ""
        .OnKey "{F11}", ""
        .OnKey "{Home}", "GoPos1"
        .OnKey "{End}", "Ende"
    End With
    ActiveSheet.EnableSelection = xlUnlockedCells
    'ActiveSheet.PageSetup.PrintArea = gconDruckbereich
ExitHere:
    Exit Sub

' Fehlerbehandlungsblock hinzugefügt vom Fehlerbehandlungsroutinen-Add-In. Bearbeiten Sie diesen Codeabschnitt NICHT.
' Automatische Fehlerbehandlungsroutine wurde zuletzt aktualisiert: 05-25-2002 17:36:32 'ErrorHandler:$$D=05-25-2002    'ErrorHandler:$$T=17:36:32
HandleErr:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Select Case Err.Number
        Case Else
            MsgBox "Fehler " & Err.Number & ": " & Err.description, vbCritical, "Tabelle1.Worksheet_Activate"   'ErrorHandler:$$N=Tabelle1.Worksheet_Activate
    End Select
' Ende des Fehlerbehandlungsblocks.
End Sub



Attribute VB_Name = "frmBeispiel"
Attribute VB_Base = "0{D36CD29F-532C-4B85-BCC2-681C7E93769D}{E40F0405-0363-421E-A303-E3DC3E88E175}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Attribute VB_Name = "basCallbacks"
Option Explicit
'################################################################
'#                                                              #
'#      Created with / Erstellt mit:                            #
'#      IDBE Ribbon Creator 2010                                #
'#      Version 1.1005                                          #
'#                                                              #
'#      (c) 2007-2011 IDBE Avenius                              #
'#                                                              #
'#      http://www.ribboncreator2010.com                        #
'#      http://www.ribboncreator.com                            #
'#      http://www.accessribon.com                              #
'#      http://www.avenius.com                                  #
'#                                                              #
'#      Aenderungswuensche oder Fehler bitte an:                #
'#                                                              #
'#      mailto://info@ribboncreator2010.com                     #
'#                                                              #
'################################################################


' Globals

Public gobjRibbon As IRibbonUI
Public gbolVorschau As Boolean

Public bolGrpUeberpruefenEnabled   'Gruppe Überprüfen anzeigen
Public bolGrpToolsEnabled   'Gruppe Tools anzeigen
Public bolCtrAnsichtAnpassenEnabled   'Ansicht anpassen einblenden

' Fuer Beispiel Callback "GetContent"
Public Type ItemsVal
    id As String
    label As String
    imageMso As String
End Type

Public Sub OnRibbonLoad(ribbon As IRibbonUI)
'Callbackname in XML File "onLoad"

    Set gobjRibbon = ribbon
'Hier wird beim Start Dienstplan gewählt, was unter Workbooks_open nicht funktioniert.
    ThisWorkbook.Sheets("Gruppe1").Select
    'Ribbon config
    bolGrpToolsEnabled = True
    bolGrpUeberpruefenEnabled = True
    bolCtrAnsichtAnpassenEnabled = True
    gobjRibbon.Invalidate
End Sub

Public Sub OnActionButton(control As IRibbonControl)
'Callback in XML File "onAction"
Dim wksAkt As Worksheet

    ' Callback für Button Click
    '********************************************************************************************´
    On Error GoTo HandleErr

    Select Case control.id
        Case "btnJahrNeu"
            Call NeuesJahr
        Case "btnAufraeumen"
            Call Aufraeumen
        Case "btnEinblenden"
            Call AllesEinblenden
        Case "btnAlternativen"
            Call Alternativen_aus_einblenden
        Case "btnGanzeBreite"
            Call GanzeBreite
        Case "btnNameAusblenden"
            Call NamenVerbergen
        Case "btnFilePrint"
            Set wksAkt = ActiveSheet
'            If wksAkt.Range("Gruppenname").Value = 0 Then
'                MsgBox "Bitte zuerst einen Gruppennamen eintragen!", vbExclamation, "Belegungsübersicht"
'                wksAkt.Range("Gruppenname").Select
'                Exit Sub
'            End If
            gbolVorschau = False 'Drucken geklickt
            gblnDruckabbruch = False
            frmDruckauswahl.Show
            wksAkt.Activate
        Case "btnFilePrintPreview"
            Set wksAkt = ActiveSheet
'            If wksAkt.Range("Gruppenname").Value = 0 Then
'                MsgBox "Bitte zuerst einen Gruppennamen eintragen!", vbExclamation, "Belegungsübersicht"
'                wksAkt.Range("Gruppenname").Select
'                Exit Sub
'            End If
            gbolVorschau = True 'Vorschau geklickt
            gblnDruckabbruch = False
            frmDruckauswahl.Show
            wksAkt.Activate
        '*******************************************************************************************
        Case Else
            MsgBox "Button """ & control.id & """ clicked" & vbCrLf & _
                           "Es wurde auf Button """ & control.id & """ in Ribbon geklickt", _
                           vbInformation
    End Select
    Set wksAkt = Nothing

    On Error GoTo 0
    Exit Sub

HandleErr:
     Application.EnableEvents = True
     Application.ScreenUpdating = True
     Set wksAkt = Nothing
     Select Case Err.Number
         Case Else
              MsgBox "Fehler " & Err.Number & " (" & Err.description & ") in Prozedur OnActionButton von Modul basCallbacks"
     End Select
End Sub

Public Sub GetEnabled(control As IRibbonControl, ByRef enabled)
    ' Callbackname in XML File "getEnabled"
    
    ' Setzen der Enabled Eigenschaft eines Ribbon Controls
    ' Weitere Informationen: http://www.accessribbon.de/index.php?Downloads:12

    Select Case control.id
        Case "btnGanzeBreite"
            enabled = bolCtrAnsichtAnpassenEnabled
        Case Else
            enabled = True
    End Select
End Sub

Public Sub GetVisible(control As IRibbonControl, ByRef visible)
    ' Callbackname in XML File "getVisible"
    
    ' Setzen der Visible Eigenschaft eines Ribbon Controls
    ' Weitere Informationen: http://www.accessribbon.de/index.php?Downloads:12

    Select Case control.id
        Case "grpTools"
            visible = bolGrpToolsEnabled
        Case "grpPruefen"
            visible = bolGrpUeberpruefenEnabled
        Case Else
            visible = True
    End Select
End Sub

Sub GetLabel(control As IRibbonControl, ByRef label)
    ' Callbackname in XML File "getLabel"
    ' To set the property "label" to a Ribbon Control

    Select Case control.id
        ''GetLabel''
        Case Else
            label = "*getLabel*"

    End Select

End Sub

Sub GetScreentip(control As IRibbonControl, ByRef screentip)
    ' Callbackname in XML File "getScreentip"
    ' To set the property "screentip" to a Ribbon Control

    Select Case control.id
        ''GetScreentip''
        Case Else
            screentip = "*getScreentip*"

    End Select

End Sub

Sub GetSupertip(control As IRibbonControl, ByRef supertip)
    ' Callbackname in XML File "getSupertip"
    ' To set the property "supertip" to a Ribbon Control

    Select Case control.id
        ''GetSupertip''
        Case Else
            supertip = "*getSupertip*"

    End Select

End Sub

Sub GetDescription(control As IRibbonControl, ByRef description)
    ' Callbackname in XML File "getDescription"
    ' To set the property "description" to a Ribbon Control

    Select Case control.id
        ''GetDescription''
        Case Else
            description = "*getDescription*"

    End Select

End Sub

Sub GetTitle(control As IRibbonControl, ByRef title)
    ' Callbackname in XML File "getTitle"
    ' To set the property "title" to a Ribbon MenuSeparator Control

    Select Case control.id
        ''GetTitle''
        Case Else
            title = "*getTitle*"

    End Select

End Sub

'EditBox

Sub GetTextEditBox(control As IRibbonControl, _
                             ByRef strText)
    ' Callbackname in XML File "GetTextEditBox"
    
    ' Callback für EditBox welcher Wert in der
    ' EditBox eingetragen werden soll.

    Select Case control.id
        Case Else
            strText = getTheValue(control.Tag, "DefaultValue")
    End Select
    
End Sub

Sub OnChangeEditBox(control As IRibbonControl, _
                              strText As String)
    ' Callbackname in XML File "OnChangeEditBox"
    
    ' Callback Editbox: Rückgabewert der Editbox

    Select Case control.id
        'Case "MyEbx"
            'If strText = "Password" Then
            '
            'End If
        Case Else
            MsgBox "The Value of the EditBox """ & control.id & """ is: " & strText & vbCrLf & _
                   "Der Wert der EditBox """ & control.id & """ ist: " & strText, _
                   vbInformation
    End Select

End Sub


Sub GetSelectedItemIndexGallery(control As IRibbonControl, _
                                   ByRef index)
    ' Callbackname in XML File "GetSelectedItemIndexGallery"
    
    ' Callback getSelectedItemIndex (Gallery)
    
    Dim varIndex As Variant
    varIndex = getTheValue(control.Tag, "DefaultValue")
    
    If IsNumeric(varIndex) Then
        Select Case control.id

            Case Else
                index = varIndex

        End Select

    End If

End Sub

Public Function getTheValue(strTag As String, strValue As String) As String
   ' *************************************************************
   ' Erstellt von     : Avenius
   ' Parameter        : Input String, SuchValue String
   ' Erstellungsdatum : 05.01.2008
   ' Bemerkungen      :
   ' Änderungen       :
   '
   ' Beispiel
   ' getTheValue("DefaultValue:=Test;Enabled:=0;Visible:=1", "DefaultValue")
   ' Return           : "Test"
   ' *************************************************************
      
   On Error Resume Next
      
   Dim workTb()     As String
   Dim Ele()        As String
   Dim myVariabs()  As String
   Dim i            As Integer

      workTb = Split(strTag, ";")
      
      ReDim myVariabs(LBound(workTb) To UBound(workTb), 0 To 1)
      For i = LBound(workTb) To UBound(workTb)
         Ele = Split(workTb(i), ":=")
         myVariabs(i, 0) = Ele(0)
         If UBound(Ele) = 1 Then
            myVariabs(i, 1) = Ele(1)
         End If
      Next
      
      For i = LBound(myVariabs) To UBound(myVariabs)
         If strValue = myVariabs(i, 0) Then
            getTheValue = myVariabs(i, 1)
         End If
      Next
      
End Function


…
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 409600 bytes
SHA-256: 17c42bb29223d82bad1dafd41d35c27eeafc1a7546bcb55d822589e554d737e1

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