Malicious Office (OOXML) — malware analysis report

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
Private Sub Workbook_Open()
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    
    Dim c4xlThere As Boolean
    Dim miniAddInThere As Boolean
    Dim c4xlWasDisconnected As Boolean
    Dim miniAddInWasDisconnected As Boolean
    c4xlThere = False
    c4xlConnected = False
    miniAddInThere = False
    miniAddInConnected = False
    Dim mainFolder As String: mainFolder = ""
    Dim hasMiniAddInData As Boolean: hasMiniAddInData = False
    
    On Error GoTo LABEL_ERROR_CALC4XL
    Set addIn = Application.COMAddIns("CALC4XL")
    c4xlThere = True
    c4xlConnected = addIn.Connect
    addIn.Connect = True

LABEL_ERROR_CALC4XL:
    On Error GoTo -1
    On Error GoTo LABEL_ERROR_MINIADDIN
    Set addIn = Application.COMAddIns("CALC4XL_CBD_miniAddIn")
    miniAddInThere = True
    miniAddInConnected = addIn.Connect
    addIn.Connect = (Not c4xlThere)
    
LABEL_ERROR_MINIADDIN:
    On Error GoTo -1
    On Error GoTo LABEL_ERROR_INSTALL
    If c4xlThere Then
        Set addIn = Application.COMAddIns("CALC4XL")
        Set automationObject = addIn.Object
        If automationObject.AreYouThere Then allGood = True
    ElseIf miniAddInThere Then
        Set addIn = Application.COMAddIns("CALC4XL_CBD_miniAddIn")
        Set automationObject = addIn.Object
        If automationObject.AreYouThere Then allGood = True
    End If
    
LABEL_ERROR_INSTALL:
    On Error GoTo -1
    On Error Resume Next
        Dim lang As String
        lang = "en"
        lang = Range("calc4xl_language").value
    On Error GoTo LABEL_ERROR
    
    If Not allGood Then 'install miniAddIn
        Dim objShell As Object
        If lang = "de" Then
            If (MsgBox("Diese Datei braucht eine CALC4XL Vollversion (kostenlose Testversion unter www.calc4xl.com) oder ein kleines Mini-AddIn, welches nun automatisch installiert werden kann." & " Soll das Mini-AddIn installiert werden?" & vbCrLf & vbCrLf & "[JA]: Installiert lediglich das ben�tigte Mini-AddIn." & vbCrLf & vbCrLf & "[NEIN]: F�hrt Sie zur CALC4XL-Homepage mit der kostenlosen CALC4XL-Testversion.", vbYesNo) = vbYes) Then
                MsgBox "Bitte w�hlen Sie einen Ordner, in dem die Installationsdateien abgelegt werden k�nnen."
            Else
                
                On Error GoTo -1
                On Error Resume Next
                    Set objShell = CreateObject("Wscript.Shell")
                    objShell.Run ("https://www.calc4xl.com")
                On Error GoTo LABEL_ERROR
                
                MsgBox "Die Datei wird bis zur Installation der CALC4XL Vollversion (kostenlose Testversion unter www.calc4xl.com) odes des Mini-AddIns auf schreibgesch�tzt gesetzt."
                Exit Sub
            End If
        Else
            If (MsgBox("This file needs a CALC4XL full version (free testversion at www.calc4xl.com) or a small Mini-AddIn which may be installed autmatically now." & " Shall the Mini-AddIn be installed?" & vbCrLf & vbCrLf & "[YES]: Will install just the necessary Mini-AddIn." & vbCrLf & vbCrLf & "[NO]: Redirects you to the CALC4XL webpage with the free CALC4XL trial version.", vbYesNo) = vbYes) Then
                MsgBox "Please choose a folder for the installation files."
            Else
            
                On Error GoTo -1
                On Error Resume Next
                    Set objShell = CreateObject("Wscript.Shell")
                    objShell.Run ("https://www.calc4xl.com/en/home/")
                On Error GoTo LABEL_ERROR
                
                MsgBox "This file will be marked as write-protected until a CALC4XL full version (free testversion at www.calc4xl.com) or the Mini-AddIn is installed."
                Exit Sub
            End If
        End If

        'get directory to save install files:
        Dim directory As String
        directory = "ERROR"
        If Application.FileDialog(msoFileDialogFolderPicker).Show = 0 Then
            If lang = "en" Then
                MsgBox "Installation aborted. Therefore the file was marked as write-protected."
            Else
                MsgBox "Installation abgebrochen. Die Datei wird daher auf schreibgesch�tzt gesetzt."
            End If
            Exit Sub
        End If
        directory = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
        
        'main folder:
        mainFolder = directory & Application.PathSeparator & "miniAddInSetup" ' & Application.PathSeparator
        'Delete folder if exisitng (otherwise copy functon will ask if copy ok
        '   Alternatively but did not always work:
        '   On Error Resume Next
        '   Kill DefPath & "*.*"
        '   RmDir "C:\Users\Andy\Desktop\testUnzipMiniAddIn"
        '   On Error GoTo 0
        Dim objFSO As Object
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        On Error GoTo -1
        On Error Resume Next 'if folder does not exist; alternatively look if folder exists
        objFSO.DeleteFolder (mainFolder) ' '\' is not allowed to be in the end of the path
        MkDir mainFolder ' '\' is allowed but not necessary
        Set objFSO = Nothing
        On Error GoTo LABEL_ERROR
        mainFolder = mainFolder & Application.PathSeparator
        
        'get setup.exe-path from customXML:
        Dim xmlPart As CustomXMLPart
        Set xmlPart = Application.ThisWorkbook.CustomXMLParts.SelectByNamespace("miniCBDAddIn").Item(1)
        hasMiniAddInData = True
        Dim setupExePath As String: setupExePath = mainFolder & xmlPart.SelectSingleNode("//ns0:file/ns0:sPath").Text + ".exe"

        'get zip-file from customXML:
        Dim file_str As String: file_str = xmlPart.SelectSingleNode("//ns0:file/ns0:data").Text
        Dim sPath_setup As String: sPath_setup = mainFolder & "CALC4XLMiniAddIn_1.zip"
        Open sPath_setup For Binary Access Write As #1
        lWritePos = 1
        Put #1, lWritePos, Base64Decode(file_str)
        Close #1
        
        'unzip file -> needs variant as parameters!
        Dim FileNameFolder As Variant: FileNameFolder = mainFolder
        Dim Fname As Variant: Fname = sPath_setup
        Dim oApp As Object
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items 'needs Variant as parameters!
        'If you want to extract only one file you can use this:
        'oApp.Namespace(FileNameFolder).CopyHere _
         'oApp.Namespace(Fname).items.Item("test.txt")
        On Error GoTo -1
        On Error Resume Next
        Dim FSO As Object
        Set FSO = CreateObject("scripting.filesystemobject")
        
        'new Andy 07.11.2018
        'may lead to false/positive message of some antivirus programs: FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
        'Therefore new:
        Dim TmpFolder As Object
        Set TmpFolder = FSO.GetSpecialFolder(2)
        FSO.DeleteFolder TmpFolder & "\Temporary Directory*", True
        'end new Andy
        
        On Error GoTo LABEL_ERROR
        
        'start setup.exe:
        On Error GoTo -1
        On Error GoTo LABEL_ERROR_EXECUTION
        'Alternatively:
        'Dim wsh As Object
        'Set wsh = VBA.CreateObject("WScript.Shell")
        'Dim waitOnReturn As Boolean: waitOnReturn = True
        'Dim windowStyle As Integer: windowStyle = 1
        'wsh.Run sPath_setup, windowStyle, waitOnReturn
        Dim process_id As Long: process_id = Shell(setupExePath, vbNormalFocus)
        
        'CLOSE file and
        '   if success resatrt
        '   if not success stay closed
        On Error GoTo -1
        On Error Resume Next
        If lang = "de" Then
            If (MsgBox("Sofern das AddIn installiert wurde, k�nnen Sie Excel schlie�en und die Datei in vollem Umfang erneut �ffnen. Danke." & vbCrLf & vbCrLf & "Die gesamte Excel-Anwendung muss neu gestartet werden. Excel schlie�en?", vbYesNo) = vbYes) Then
                Application.Quit
                Exit Sub
            Else
                MsgBox "Bis zum Schlie�en und erneuten Starten der Excel-Anwendung wird die Datei auf schreibgesch�tzt gesetzt."
                'ThisWorkbook.Close (False)
                Exit Sub
            End If
        Else
            If (MsgBox("If the AddIn was installed, please close Excel and open the file again to use it with all functionalities. Thank you." & vbCrLf & vbCrLf & "The whole Excel application has to be restarted. Close Excel?", vbYesNo) = vbYes) Then
                Application.Quit
                Exit Sub
            Else
               MsgBox "Until you have closed and reopened Excel, the file is marked as write-protected."
                'ThisWorkbook.Close (False)
                Exit Sub
            End If
        End If
        
    'now done in wbOpen-event of miniAddIn:
    'Else
        'On Error GoTo -1
        'On Error Resume Next
        'If (Not c4xlThere And miniAddInThere) Then
        '    automationObject.CBD_hasCALC4XLModulesHint
        'End If
    End If
    
    
LABEL_ERROR:
    On Error GoTo -1
    On Error Resume Next
    If Not allGood Then
        'Dim lang As String
        'lang = "en"
        'lang = Range("calc4xl_language").value
        If lang = "de" Then
            If hasMiniAddInData Then
                MsgBox "Nicht in der Lage, das Mini-AddIn automatisch zu laden. Bitte laden Sie es unter www.calc4xl.com/AddIns herunter, entzippen Sie es und starten mittels Doppelklick auf Setup." & vbCrLf & vbCrLf & "Alternativ k�nnen Sie auch eine CALC4XL Vollversion kostenlos unter www.calc4xl.com herunterladen. Die Datei wird mit aktiver und abgelaufener Lizenz funktionieren. Danke." & vbCrLf & vbCrLf & "Die Datei wurde auf schreibgesch�tzt gesetzt."
            Else
                MsgBox "Diese Datei wurde nicht f�r Nutzer ohne CALC4XL Vollversion vorbereitet. Sie brauchen eine CALC4XL Vollversion oder Fragen Sie den Absender dieser Datei nach einer f�r Nutzer ohne CALC4XL vorbereiteten Version. Danke. Die Datei wurde auf schreibgesch�tzt gesetzt."
            End If
            'try to open webpage:
            Set objShell = CreateObject("Wscript.Shell")
            objShell.Run ("https://www.calc4xl.com/AddIns")
        Else
            If hasMiniAddInData Then
                MsgBox "Not able to load the mini AddIn automatically. Please go to www.calc4xl.com/en/AddIns to download the AddIn manually. Afterwards please extract the file and start the installation by double-click on 'Setup'." & vbCrLf & vbCrLf & "Alternatively you can install the CALC4XL full verion at www.calc4xl.com. This file will be working with active and expired CALC4XL license." & vbCrLf & vbCrLf & "The file was marked as write-protected."
            Else
                MsgBox "This file has not been prepared to be used by users without CALC4XL full version. You need a CALC4XL full version or ask the sender of this file for a version which is prepared for users without CALC4XL. Thank you. The file was marked as write-protected."
            End If
            'try to open webpage:
            Set objShell = CreateObject("Wscript.Shell")
            objShell.Run ("https://www.calc4xl.com/en/AddIns")
        End If
        'ThisWorkbook.Close (False)
    End If
    Exit Sub
    
LABEL_ERROR_EXECUTION:
    On Error GoTo -1
    On Error Resume Next
    If lang = "de" Then
        MsgBox "Nicht in der Lage, die Installationsdatei autmatisch zu laden. Bitte starten Sie '" & setupExePath & "' manuell! Bis dahin wird die Datei auf schreibgesch�tzt gesetzt."
    Else
        MsgBox "Not able to install automatically. Please start '" & setupExePath & "' manually! Before then this file will be marked as write-protected."
    End If
    On Error GoTo LABEL_ERROR_FOLDER
    Shell "explorer.exe" & " " & mainFolder, vbNormalFocus
    'ThisWorkbook.Close (False)
    Exit Sub
    
LABEL_ERROR_FOLDER:
    On Error GoTo -1
    On Error Resume Next
    If lang = "de" Then
        MsgBox "Sie finden die Setup-Datei unter '" & mainFolder & "'. Bis zur Installation wird die Datei auf schreibgesch�tzt gesetzt."
    Else
        MsgBox "You will find the setup-file at '" & mainFolder & "'. Before installation this file will be marked as write-protected."
    End If
    'ThisWorkbook.Close (False)
    Exit Sub
    
End Sub




Attribute VB_Name = "Sheet3"
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
Dim mode As String
Public StrPassword As String
Public targetFlag As Integer


Private Sub CmdClearSheet_Click()
   Dim Selection As Integer
   Application.ScreenUpdating = False
   Application.EnableEvents = False

        Selection = MsgBox("Are you sure? All data will be deleted!", vbYesNo)
        Select Case Selection
            Case vbYes
                Range("D4:G6").ClearContents
                Range("D7").value = "USD: US Dollar"
                Range("F7").value = "/pc"
                
                Range("J4:K4").ClearContents
                Range("J5").ClearContents
                Range("J6:K8").ClearContents
                Range("D9:K10").ClearContents
                Range("M6:P6").ClearContents
                Range("N7:P10").ClearContents
                
                Range("M13").value = "Frt in [%]"
                Range("M36").value = "Frt in [%]"
                
                Range("B14:N33").ClearContents
                Range("B37:N60").ClearContents
                Range("B66:N89").ClearContents
                    
                Range("E99:H100").ClearContents
                Range("K99:K100").ClearContents
                Range("M99:N100").ClearContents
                
                Range("D108:J109").ClearContents
                Range("L108:N109").ClearContents
                
                Range("B113:B114").ClearContents
                Range("C112:N114").ClearContents
                Range("C112").value = "FCA"
                
                Range("D116:E116").ClearContents
                Range("H116:I117").ClearContents
                Range("A118:I119").ClearContents
                Range("B123:O130").ClearContents
                Range("G133:K134").ClearContents
                Range("G135:H137").ClearContents
            
                Range("G141:H141").ClearContents
                Range("I141:I144").ClearContents
                Range("J148:O149").ClearContents
                Range("G152:O153").ClearContents
                
                Range("K108").Formula = "=IF(D108*E108*F108=0,1,MAX(ROUNDDOWN(920/D108,0)*ROUNDDOWN(1200/E108,0),ROUNDDOWN(1200/D108,0)*ROUNDDOWN(920/E108,0))*ROUNDDOWN(840/F108,0))"
                Range("K109").Formula = "=IF(D109*E109*F109=0,1,MAX(ROUNDDOWN(920/D109,0)*ROUNDDOWN(1200/E109,0),ROUNDDOWN(1200/D109,0)*ROUNDDOWN(920/E109,0))*ROUNDDOWN(840/F109,0))"
                
                Range("Y66:AB89").ClearContents
                Range("AE66:AE89").ClearContents
                Range("AJ66:AK89").ClearContents
            
                Range("AA108:AB109").ClearContents
                
            '    Range("").ClearContents
            
                Application.EnableEvents = True
                Range("K112").ClearContents
               
                Range("D4").Activate
               
            Case vbNo
                Application.EnableEvents = True

        End Select

    Application.ScreenUpdating = True

End Sub

Private Sub CmdClearSheet_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

End Sub

Private Sub cmdCopySheet_Click()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_copySheet
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub cmdPrint_Click()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_allgemein_cmdPrint_Click
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If

End Sub


Private Sub cmdPartPicture_Click()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_partPicture_click
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If

End Sub

'NEU 2016_02_05 NEU NEU NEU NEU NEU NEU NEU NEU NEU NEU
'NICHT �BERSETZEN IN C#, da es neu umgesetzt wird
Private Sub orderSection24_Click() 'IGNORE!!!!!!!
    'maybe do not put to C# as would be probably slower.

    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    If Not automationObject.CBD_licenseOk Then Exit Sub
    If Not automationObject.CBD_hasRightsOnWs(Application.ActiveSheet) Then Exit Sub
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
        Exit Sub
    End If

Dim actRow As Integer
Dim rightRow As Integer
Dim AN90_setup_str As String
Dim foundRightRow As Boolean
Dim noMessage As Boolean
Dim somethingSorted As Boolean

noMessage = False
somethingSorted = False

'PasswordBreaker

Application.ScreenUpdating = False
Application.EnableEvents = True 'have to be true so CALC4Xl can update cell-positions

Range("calc4xlHintCell").value = "proc_sorting"

AN90_setup_str = "A90:AT90"
For actRow = 66 To 89
    If Range("A" & actRow).value <> (actRow - 65) Then
        somethingSorted = True
        Range("A" & actRow & ":AT" & actRow).Cut Range(AN90_setup_str)
        If Range("calc4xlHintCell").value = "proc_break" Then
            noMessage = True
            GoTo line_forceBreak
        End If
        foundRightRow = False
        For rightRow = 66 To 89
            If Range("A" & rightRow).value = (actRow - 65) Then
                Range("A" & rightRow & ":AT" & rightRow).Cut Range("A" & actRow & ":AT" & actRow)
                If Range("calc4xlHintCell").value = "proc_break" Then
                    Range("A" & actRow & ":AT" & actRow).Cut Range("A" & rightRow & ":AT" & rightRow)
                    noMessage = True
                    GoTo line_forceBreak
                End If
                Range(AN90_setup_str).Cut Range("A" & rightRow & ":AT" & rightRow)
                If Range("calc4xlHintCell").value = "proc_break" Then
                    Range("A" & rightRow & ":AT" & rightRow).Cut Range(AN90_setup_str)
                    Range("A" & actRow & ":AT" & actRow).Cut Range("A" & rightRow & ":AT" & rightRow)
                    noMessage = True
                    GoTo line_forceBreak
                End If
                foundRightRow = True
                Exit For
            End If
        Next
        If Not foundRightRow Then
line_forceBreak:
            Range(AN90_setup_str).Cut Range("A" & actRow & ":AT" & actRow)
            Range("calc4xlHintCell").value = "proc_none"
            Application.ScreenUpdating = True
            If Not noMessage Then
                If Range("calc4xl_language").value = "de" Then
                    MsgBox ("Keine Zeile mit Ordnungsnummer " & (actRow - 65) & " gefunden! Bitte geben Sie alle Nummern von 1 bis 24 an (ohne Doppelungen). Das Sortieren wird abgebrochen!")
                Else
                    MsgBox ("Was not able to find line for row " & (actRow - 65) & "! Please fill in numbers 1 to 24 (no doubling). Abort sorting!")
                End If
            End If
            Exit Sub
        End If
    End If
Next

Range("calc4xlHintCell").value = "proc_none"
Application.ScreenUpdating = True

If Not somethingSorted Then
    If Range("calc4xl_language").value = "de" Then
        MsgBox ("Schreiben Sie unterhalb dieses Schalters die Ornungsnummern 1 bis max. 24 (ohne Doppelungen) und dr�cken Sie auf 'Sort', dann werden die Zeilen entsprechend Ihrer Vorgabe neu sortiert.")
    Else
        MsgBox ("Fill the column below this button with the order-numbers 1 to maximum 24 (no doubling) und press 'Sort'. Then the lines will be reordered according to your numbers.")
    End If
End If


End Sub
'ENDE NEU 2016_02_05 NEU NEU NEU NEU NEU NEU NEU NEU NEU NEU

Private Sub SpinButton1_SpinDown()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton1_spinDown
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub SpinButton1_SpinUp()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton1_spinUp
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub SpinButton2_SpinDown()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton2_spinDown
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub
Sub isChangeLegal() 'not used at the moment as subroutines check it by it's own => delete in subs and put this function

    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        ThisWorkbook.Close (False)
    End If
    
End Sub

Private Sub SpinButton2_SpinUp()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton2_spinUp
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub SpinButton3_SpinDown()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton3_spinDown
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub SpinButton3_SpinUp()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton3_spinUp
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub SpinButton4_SpinDown()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton4_spinDown
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub SpinButton4_SpinUp()
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    automationObject.CBD_spinButton4_spinUp
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
        End If
        'ThisWorkbook.Close (False)
    End If
End Sub



Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    Call automationObject.CBD_worksheet_selectionChange(Target)
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
'        If Range("calc4xl_language").value = "de" Then
'            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
'        Else
'            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
'        End If
'        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
'isChangeLegal '-> all done now by own code ;-)


    On Error GoTo LABEL_ERROR
    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    Call automationObject.CBD_worksheet_change(Target)
    
LABEL_ERROR:
    On Error Resume Next
    If Not allGood Then
        If Range("calc4xl_language").value = "de" Then
            MsgBox "�ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com" & vbCrLf & vbCrLf & "Diese Datei wird nun geschlossen."
        Else
            MsgBox "Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com" & vbCrLf & vbCrLf & "This file will be closed now."
        End If
        ThisWorkbook.Close (False)
    End If

End Sub



Sub FormatPage()
Dim CurrCell As String
   
   CurrCell = ActiveCell.Address
   '  ActiveWindow.View = xlPageBreakPreview
   If ActiveSheet.PageSetup.PaperSize = xlPaperA4 Then
      If Range("W10").value <= 272 Then
         ActiveSheet.ResetAllPageBreaks
         Range("A131").Select
         ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
         If Range("W10").value <= 261 Then ActiveSheet.PageSetup.Zoom = 80 Else ActiveSheet.PageSetup.Zoom = 75
         If Range("W10").value > 266 Then ActiveSheet.PageSetup.Zoom = 70
      Else
'         If ActiveSheet.HPageBreaks.Count > 0 Then ActiveSheet.HPageBreaks(ActiveSheet.HPageBreaks.Count).Delete
         ActiveSheet.ResetAllPageBreaks
         ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range("A120").Offset(1)
         If Range("V10").value > 147 Then ActiveSheet.PageSetup.Zoom = 70 Else ActiveSheet.PageSetup.Zoom = 75
         If Range("V10").value > 153 Then ActiveSheet.PageSetup.Zoom = 65
         If Range("V10").value > 159 Then ActiveSheet.PageSetup.Zoom = 60
         If Range("V10").value > 167 Then ActiveSheet.PageSetup.Zoom = 55
         If Range("V10").value > 176 Then ActiveSheet.PageSetup.Zoom = 52
      End If
   
   ElseIf ActiveSheet.PageSetup.PaperSize = xlPaperLetter Then
      If Range("W10").value <= 272 Then
         ActiveSheet.ResetAllPageBreaks
         Range("A131").Select
         ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
         If Range("W10").value <= 256 Then ActiveSheet.PageSetup.Zoom = 80 Else ActiveSheet.PageSetup.Zoom = 75
         If Range("W10").value > 260 Then ActiveSheet.PageSetup.Zoom = 70
         If Range("W10").value > 265 Then ActiveSheet.PageSetup.Zoom = 65
      Else
'         If ActiveSheet.HPageBreaks.Count > 0 Then ActiveSheet.HPageBreaks(ActiveSheet.HPageBreaks.Count).Delete
         ActiveSheet.ResetAllPageBreaks
         ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Range("A120").Offset(1)
         If Range("V10").value > 147 Then ActiveSheet.PageSetup.Zoom = 65 Else ActiveSheet.PageSetup.Zoom = 70
         If Range("V10").value > 153 Then ActiveSheet.PageSetup.Zoom = 60
         If Range("V10").value > 160 Then ActiveSheet.PageSetup.Zoom = 55
         If Range("V10").value > 169 Then ActiveSheet.PageSetup.Zoom = 50
         If Range("V10").value > 179 Then ActiveSheet.PageSetup.Zoom = 48
      End If
   End If

    ActiveSheet.PageSetup.PrintArea = "$A$1:$P$176"
  ' ActiveWindow.View = xlNormalView
    Range(CurrCell).Activate
End Sub

'new subroutine: -> delte whole routine, DO NOT USE ANYMORE
Private Sub PasswordBreaker() '-> l�schen!
    'Breaks worksheet password protection.
    If ((Not ActiveSheet.ProtectContents) Or ActiveSheet.ProtectionMode) Then
        Exit Sub 'already just userInterfaceOnly=true
    End If
    'rest deleted as do not use anymore
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

Attribute VB_Name = "Sheet97"
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
Dim sheetName As String

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    On Error GoTo LABEL_ERROR_SelectionChange

    If ActiveCell.Address <> Range("A1").Address Then
            If ActiveWindow.SelectedSheets.Count > 1 Then
                MsgBox "Please don't make changes with multiple sheets selected."
                ActiveSheet.Select
            End If
    End If
    sheetName = "Summary"
    If Not ActiveSheet.Name = sheetName Then
        MsgBox "Sheet Name Cannot be changed"
        Me.Name = sheetName
    End If
LABEL_ERROR_SelectionChange:
    On Error GoTo -1
    On Error Resume Next
    'Do nothing
End Sub

Private Sub Worksheet_Activate()
    On Error Resume Next
    Application.CommandBars.FindControl(ID:=847).Enabled = False

    Dim allGood As Boolean
    allGood = False
    Dim addIn As COMAddIn
    Dim automationObject As Object
    
    On Error GoTo LABEL_ERROR_CALC4XL 'ok as afer On Error Resume Next is On Error Goto Label allowed
    Set addIn = Application.COMAddIns("CALC4XL")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
    
LABEL_ERROR_CALC4XL:
    On Error GoTo -1
    On Error GoTo LABEL_ERROR
If Not allGood Then
    Set addIn = Application.COMAddIns("CALC4XL_CBD_miniAddIn")
    Set automationObject = addIn.Object
    If automationObject.AreYouThere Then allGood = True
End If
    automationObject.CBD_SummaryActivate
    
LABEL_ERROR:
    On Error GoTo -1
    On Error Resume Next
    If Not allGood Then

'Does it work?
' if reactivated then use         Dim lang As String
'                                 lang = "en"
'                                 lang = Range("calc4xl_language").value
' maybe problem is that calc4xl_language is not workbook-name but just worksheet-name
'        If Range("calc4xl_language").value = "de" Then
'            MsgBox "Schreibgesch�tzte Datei: �ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
'        Else
'            MsgBox "Protected file: Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com"
'        End If
        MsgBox "ENGLISH:" & vbCrLf & vbCrLf & vbTab & "Protected file: Do not change this file without CALC4XL!" & vbCrLf & vbCrLf & vbTab & "You will find more information and a free testversion at www.calc4xl.com or write to info@calc4xl.com" & vbCrLf & vbCrLf & vbCrLf & "DEUTSCH:" & vbCrLf & vbCrLf & vbTab & "Schreibgesch�tzte Datei: �ndern Sie diese Datei nicht ohne CALC4XL!" & vbCrLf & vbCrLf & vbTab & "Weitere Informationen und eine kostenlose Testversion finden Sie unter www.calc4xl.com oder schreiben Sie an info@calc4xl.com"
        'ThisWorkbook.Close (False)
    End If
End Sub

Private Sub Worksheet_Deactivate()
    On Error Resume Next
    Application.CommandBars.FindControl(ID:=847).Enabled = True
    Me.Name = "Summary"
End Sub




Attribute VB_Name = "Modul1"
' A Base64 Encoder/Decoder from http://www.source-code.biz/snippets/vbasic/Base64Coder.bas.txt
'
' This module is used to encode and decode data in Base64 format as described in RFC 1521.
'
' Home page: www.source-code.biz.
' Copyright 2007: Christian d'Heureuse, Inventec Informatik AG, Switzerland.
'
' This module is multi-licensed and may be used under the terms
' of any of the following licenses:
'
'  EPL, Eclipse Public License, V1.0 or later, http://www.eclipse.org/legal
'  LGPL, GNU Lesser General Public License, V2.1 or later, http://www.gnu.org/licenses/lgpl.html
'  GPL, GNU General Public License, V2 or later, http://www.gnu.org/licenses/gpl.html
'  AGPL, GNU Affero General Public License V3 or later, http://www.gnu.org/licenses/agpl.html
'  AL, Apache License, V2.0 or later, http://www.apache.org/licenses
'  BSD, BSD License, http://www.opensource.org/licenses/bsd-license.php
'  MIT, MIT License, http://www.opensource.org/licenses/MIT
'
' Please contact the author if you need another license.
' This module is provided "as is", without warranties of any kind.

Option Explicit

Private InitDone       As Boolean
Private Map1(0 To 63)  As Byte
Private Map2(0 To 127) As Byte


' Decodes a byte array from Base64 format.
' Parameters
'   s         a Base64 String to be decoded.
' Returns:    an array containing the decoded data bytes.
Public Function Base64Decode(ByVal s As String) As Byte()
   If Not InitDone Then Init
   Dim IBuf() As Byte: IBuf = ConvertStringToBytes(s)
   Dim ILen As Long: ILen = UBound(IBuf) + 1
   If ILen Mod 4 <> 0 Then Err.Raise vbObjectError, , "Length of Base64 encoded input string is not a multiple of 4."
   Do While ILen > 0
      If IBuf(ILen - 1) <> Asc("=") Then Exit Do
      ILen = ILen - 1
      Loop
   Dim OLen As Long: OLen = (ILen * 3) \ 4
   Dim Out() As Byte
   ReDim Out(0 To OLen - 1) As Byte
   Dim ip As Long
   Dim op As Long
   Do While ip < ILen
      Dim i0 As Byte: i0 = IBuf(ip): ip = ip + 1
      Dim i1 As Byte: i1 = IBuf(ip): ip = ip + 1
      Dim i2 As Byte: If ip < ILen Then i2 = IBuf(ip): ip = ip + 1 Else i2 = Asc("A")
…