Malicious Office (OOXML) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
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

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  'SluitDBToegang
End Sub

Private Sub Workbook_Open()
  If OntwikkelZonderStartApplicatie() Then
    'OPEN IN DESIGN/DEVELOPER MODE:
  Else
    'OPEN IN EXECUTE MODE:
    If ThisWorkbook.Sheets.Count = 1 Then
      If ThisWorkbook.Sheets(1).CodeName = "wsInstall" Then
        If ProtectedView(ThisWorkbook) Then
          MsgBox "This tool cannot run in protected view. Please check your Excel setting in the Trust Center and restart the Setup tool."
          CloseWorkBook ThisWorkbook
        Else
          On Error GoTo Finally
          wsInstall.Activate
          On Error GoTo 0
          InitApplicatie
          CloseWorkBook ThisWorkbook
        End If
      Else
        ErrorMessageAndQuit "(1)"
      End If
    Else
      ErrorMessageAndQuit "(2)"
    End If
  End If
Finally:
  'Na het opstarten van de nieuwe BT komt de Setup tool opnieuw in het Workbook_Open event en faalt de wsInstall.Activate en wordt de Setup tool alsnog gesloten
  CloseWorkBook ThisWorkbook
End Sub

Public Sub ErrorMessageAndQuit(strError As String)
  MsgBox "Please restart the Setup tool. If this message still appears please check your Excel setting in the Trust Center." & IIf(Len(strError) > 0, vbCrLf & "Error " & strError, "")
  CloseWorkBook ThisWorkbook
End Sub

Public Function ProtectedView(ByRef wb As Workbook) As Boolean
  Dim intCount As Integer, i As Integer
  
  On Error GoTo Finally
  
  ProtectedView = False
  intCount = wb.Application.ProtectedViewWindows.Count
  If intCount > 0 Then
    For i = 1 To intCount
      If wb.Application.ProtectedViewWindows(i).Workbook.Name = wb.Name Then
        ProtectedView = True
        Exit For
      End If
    Next
  End If
  
Finally:
End Function

Attribute VB_Name = "wsInstall"
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


Attribute VB_Name = "modSHARED_CheckOfficeVersion"
Option Explicit

'LAATST_GEWIJZIGD: 2019_08_12 - 2020-12-28 HJ
'DIT IS EEN ZOGENAAMDE "SHARED MODULE" DIE IN MEERDERE APPLICATIES IN (VRIJWEL) EXACT DEZELFDE VORM IS OPGENOMEN.
'LATEN WE PROBEREN OM DE SHARED MODULES ZO VEEL MOGELIJK UP-TO-DATE TE HOUDEN MET ELKAAR, BOVENSTAANDE LAATST_GEWIJZIGD
'DATUM DIENT TER ONDERSTEUNING HIERVAN.
 
Public Declare PtrSafe Sub GetNativeSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
  
Public Const REGISTRY_NO_SETTING_FOUND = "NoSettingFound"
Private Const REGISTRY_APPNAME = "ApplicatiePlaza365"
Private Const REGISTRY_SECTION = "General"
Private Const REGISTRY_KEY = "CheckOfficeVersionDate"

Type SYSTEM_INFO
  wProcessorArchitecture As Integer
  wReserved As Integer
  dwPageSize As LongPtr
  lpMinimumApplicationAddress As LongPtr
  lpMaximumApplicationAddress As LongPtr
  dwActiveProcessorMask As LongPtr
  dwNumberOrfProcessors As LongPtr
  dwProcessorType As LongPtr
  dwAllocationGranularity As LongPtr
  wProcessorLevel As Integer
  wProcessorRevision As Integer
End Type

Public Function CheckOfficeVersion(Optional ByVal blnDisplayMessage As Boolean = True, Optional ByVal blnDutch As Boolean = False, Optional ByVal blnAllowOtherVersions As Boolean = True) As Boolean
  Const OPTIMALVERSION = "16.0"
  Dim blnRes As Boolean
  Dim strVersion As String
  Dim strMsg As String, strTitle As String
  Dim blnMakeDecision As Boolean

  blnRes = False
  blnMakeDecision = False
  On Error GoTo Finally:
  strVersion = Application.Version
  If strVersion < OPTIMALVERSION Then
    If blnDisplayMessage Then
      If blnDutch Then
        strMsg = "Deze versie van Microsoft Office is te oud om deze applicatie correct te laten werken." & IIf(blnAllowOtherVersions, " Wilt u ondanks dat toch proberen door te gaan?", "")
        strTitle = "Office versie probleem"
      Else
        strMsg = "This version of Microsoft Office is to old for proper use of this application." & IIf(blnAllowOtherVersions, " Do you want to try to continue despite this?", "")
        strTitle = "Office version problem"
      End If
      If blnAllowOtherVersions Then
        blnMakeDecision = True
      Else
        MsgBox strMsg, vbInformation, strTitle
      End If
    End If
  ElseIf strVersion > OPTIMALVERSION Then
    If blnDisplayMessage Then
      If blnDutch Then
        strMsg = "Deze versie van Microsoft Office is nieuwer dan waarvoor deze applicatie is geoptimaliseerd." & IIf(blnAllowOtherVersions, " Wilt u ondanks dat toch proberen door te gaan?", "")
        strTitle = "Office versie probleem"
      Else
        strMsg = "This version of Microsoft Office is newer then the version for which this application is optimized." & IIf(blnAllowOtherVersions, " Do you want to try to continue despite this?", "")
        strTitle = "Office version problem"
      End If
      If blnAllowOtherVersions Then
        blnMakeDecision = True
      Else
        MsgBox strMsg, vbInformation, strTitle
      End If
    End If
  Else
    blnRes = True
  End If
  If blnMakeDecision Then
    'DE MELDING WORDT GETOOND AAN DE GEBRUIKER. ALS DEZE ER VOOR KIEST OM ONDANKS DE MELDING
    'TOCH DOOR TE GAAN DAN WORDT DE MELDING DE REST VAN DE DAG NIET MEER GETOOND (DIT WORDT
    'BIJGEHOUDEN IN DE REGISTRY) ANDERS ZOU HET IRRITANT WORDEN.
    'ALS DE GEBRUIKER NEGATIEF KIEST DAN VERSCHIJNT DE MELDING
    '(OP DEZELFDE DAG) DE VOLGENDE KEER GEWOON WEER:
    If GetOfficeVersionCheckedToday() Then
      blnRes = True
    Else
      'NOW CHECK OFFICE VERSION TODAY:
      blnRes = (MsgBox(strMsg, vbYesNoCancel, strTitle) = vbYes)
      If blnRes Then
        SetOfficeVersionCheckedToday
      End If
    End If
  End If
  
  RegisterSharepoint
  ChangeMacroSettings
  
Finally:
  CheckOfficeVersion = blnRes
End Function

Private Function GetOfficeVersionCheckedToday() As Boolean
  Dim blnRes As Boolean
  Dim strValue As String
  Dim varValue As Variant
  
  blnRes = False
  On Error GoTo Finally:
  'HAAL DE OPGESLAGEN WAARDE UIT DE REGISTRY (ALS-IE BESTAAT):
  strValue = ""
  varValue = Interaction.GetSetting(REGISTRY_APPNAME, REGISTRY_SECTION, REGISTRY_KEY, REGISTRY_NO_SETTING_FOUND)
  If varValue <> REGISTRY_NO_SETTING_FOUND Then
    strValue = varValue
  End If
  blnRes = (strValue = GetStringToday())
Finally:
  GetOfficeVersionCheckedToday = blnRes
End Function

Private Sub SetOfficeVersionCheckedToday()
  'SLA DE DAG-WAARDE OP IN DE REGISTRY:
  Interaction.SaveSetting REGISTRY_APPNAME, REGISTRY_SECTION, REGISTRY_KEY, GetStringToday()
End Sub

Private Function GetStringToday() As String
  GetStringToday = Format(Date, "dd-mm-yyyy")
End Function

Public Function Is64BitProcessor() As Boolean
  Const PROCESSOR_ARCHITECTURE_AMD64 As Integer = 9
  Const PROCESSOR_ARCHITECTURE_IA64 As Integer = 6
  Dim si As SYSTEM_INFO
  ' call the API
  GetNativeSystemInfo si
  ' check the architecture
  Is64BitProcessor = (si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 Or si.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_IA64)
End Function

Attribute VB_Name = "modSHARED_ExecuteFileDSE"
Option Explicit

'LAATST_GEWIJZIGD: 2020_01_17
'DIT IS EEN ZOGENAAMDE "SHARED MODULE" DIE IN MEERDERE APPLICATIES IN (VRIJWEL) EXACT DEZELFDE VORM IS OPGENOMEN.
'LATEN WE PROBEREN OM DE SHARED MODULES ZO VEEL MOGELIJK UP-TO-DATE TE HOUDEN MET ELKAAR, BOVENSTAANDE LAATST_GEWIJZIGD
'DATUM DIENT TER ONDERSTEUNING HIERVAN.

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Const DSE_DOWNLOAD_EXTENSION0 = "_ds"
Public Const DSE_DOWNLOAD_EXTENSION1 = DSE_DOWNLOAD_EXTENSION0 & "e"
Public Const DSE_DOWNLOAD_EXTENSION2 = DSE_DOWNLOAD_EXTENSION0 & "2"
Public Const DSE_DOWNLOAD_EXTENSION3 = DSE_DOWNLOAD_EXTENSION0 & "3"
Public Const DSE_APPLICATIONS_FOLDER = "DSE_Applications"
Private p_slUploadFromUserHome() As String

Public Function ExecuteFile(ByVal strFullName As String) As Boolean
  Const WITH_DOT = True
  Dim blnRes As Boolean
  Dim blnIsTestEnvironment As Boolean
  Dim blnIsLiveEnvironment As Boolean
  Dim strSep As String
  Dim strDotExt As String
  Dim blnShellExcel As Boolean
  Dim blnDownload As Boolean
  Dim blnDoorgaan As Boolean
  Dim strExecuteName As String
  Dim strOmgeving As String
  Dim blnKnownExtension As Boolean
  Dim blnUploadFromUserHome As Boolean
  Dim strToolName As String
  Dim lngIndex As Long
  Dim intReply As Integer
  
  blnRes = False
  blnDoorgaan = True
  On Error GoTo Finally:
  
  'DETERMINE THE ENVIRONMENT: LIVE OR TEST:
  strSep = DetermineSeparator(strFullName)
  blnIsTestEnvironment = (InStr(1, strFullName, TestIndicatorInPath(strSep), vbTextCompare) > 0)
  blnIsLiveEnvironment = (Not blnIsTestEnvironment)
  
  'HANDEL HET EXTENSIONTYPE _ds3 (DOWN- EN UPLOAD VAN OFFICE-TOOLS) AF:
  If UCase(Right(strFullName, Len(DSE_DOWNLOAD_EXTENSION3))) = UCase(DSE_DOWNLOAD_EXTENSION3) Then
    'BIJ DSE_DOWNLOAD_EXTENSION3 KAN ÉÉN VAN DE VOLGENDE ACTIES NODIG ZIJN:
    '1. DOWNLOAD READ-ONLY
    '2. DOWNLOAD FULL-ACCES
    '3. UPLOAD NEW VERSION
    lngIndex = StringArrayIndex(p_slUploadFromUserHome, strFullName)
    blnUploadFromUserHome = (lngIndex >= 0)
    strToolName = RemoveFileExtension(GetFileNameFromFullName(strFullName))
    If blnUploadFromUserHome Then
      intReply = MsgBox("Wilt u uw bewerkte " & strToolName & " nu uploaden en voor alle gebruikers beschikbaar maken? (Kies [Nee] om niet te uploaden, uw check-out van " & strToolName & " vervalt in beide gevallen)", vbYesNoCancel, strToolName & " uploaden?")
      If intReply = vbCancel Then
        'DOE NIETS
      ElseIf intReply = vbYes Then
        If UploadFromUserHome(strFullName, blnIsTestEnvironment) Then
          MsgBox "Uw upload van " & strToolName & " is gereed.", , "ToolMetData is ge-upload"
        Else
          MsgBox "Uw upload van " & strToolName & " is NIET gelukt.", , "ToolMetData NIET ge-upload"
        End If
        StringArrayDelete p_slUploadFromUserHome, lngIndex
      Else
        StringArrayDelete p_slUploadFromUserHome, lngIndex
      End If
      blnDoorgaan = False
    Else
      intReply = MsgBox("Wilt u uw bewerkingen op " & strToolName & " na afloop uploaden en voor alle gebruikers beschikbaar maken? (Kies [Nee] om " & strToolName & " te starten zonder de bewerkingen te kunnen opslaan)", vbYesNoCancel, strToolName & " uitchecken en bewerken?")
      If intReply = vbCancel Then
        blnDoorgaan = False
      ElseIf intReply = vbYes Then
        MsgBox strToolName & " is nu door u uitgechecked. Als uw lokale bewerkingen zijn bewaard en " & strToolName & " is afgesloten, kies dan voor uploaden via ApplicatiePlaza365 (via dezelfde [" & strToolName & "] knop.", , strToolName & " uitgechecked"
        StringArrayAdd p_slUploadFromUserHome, strFullName
      Else
        'DOE NIETS SPECIAALS
      End If
    End If
  End If
  
  If blnDoorgaan Then
    strDotExt = GetFileExtension(strFullName, strSep, WITH_DOT)
    
    'A FILE EXTENTION OF THE FORM ".*_dse" (SO FOR EXAMPLE ".xlsm_dse" OR ".xlsb_dse" OR ".mdb_dse")
    'IS A FLAG TO INDICATE A DOWNLOAD OF THE FILE TO THE USER HOME ENVIRONMENT FROM WHERE THE EXECUTE WILL CONTINUE,
    'THIS IS THE SAME FUNCTIONALITY AS THE FORMER "STARTER" FILES.
    
    blnShellExcel = (UCase(Right(strDotExt, Len(DSE_DOWNLOAD_EXTENSION2))) = UCase(DSE_DOWNLOAD_EXTENSION2))
    blnDownload = (InStr(1, strDotExt, DSE_DOWNLOAD_EXTENSION0, vbTextCompare) > 0)
    If blnDownload Then
      blnDoorgaan = DownloadToUserHome(strFullName, blnIsTestEnvironment, strExecuteName)
      strSep = DetermineSeparator(strExecuteName)
      strDotExt = GetFileExtension(strExecuteName, strSep, WITH_DOT)
    Else
      If FileExists(strFullName) Then
        blnDoorgaan = True
        strExecuteName = strFullName
      Else
        blnDoorgaan = False
        MsgBox "The requested file has not been found." & vbCrLf & "Failed to open the following file: " & strFullName, , "Fout in ExecuteFile"
      End If
    End If
    
    If blnDoorgaan Then
      If Len(strDotExt) = 0 Then
        blnKnownExtension = False
      Else
        'NOW EXECUTE THE FILE WITH EITHER EXCEL, ACCESS, OR A REGISTERED DEFAULT PROGRAM:
        If InStr(1, ".xls;.xlsm;.xlsb", strDotExt, vbTextCompare) > 0 Then
          If blnShellExcel Then
            Shell "excel.exe """ & strExecuteName & """", vbNormalFocus
          Else
            Workbooks.Open strExecuteName
          End If
          blnRes = True
          blnKnownExtension = True
        ElseIf InStr(1, ".mdb;.accdb;.mde;.accde", strDotExt, vbTextCompare) > 0 Then
          If MSAccessIsAvailable() Then
            If blnIsTestEnvironment Then
              strOmgeving = " /cmd ""TEST"""
            End If
            If blnIsLiveEnvironment Then
              strOmgeving = " /cmd ""PRODUCTIE"""
            End If
            Shell "msaccess.exe """ & strExecuteName & """" & strOmgeving, vbNormalFocus
            blnRes = True
          End If
          blnKnownExtension = True
        ElseIf InStr(1, ".docx;.docm;.doc;.dotx;.dotm;.dot", strDotExt, vbTextCompare) > 0 Then
          Shell "winword.exe """ & strExecuteName & """", vbNormalFocus
          blnKnownExtension = True
        End If
      End If
      
      If Not blnKnownExtension Then
        If ShellOpenFile(strExecuteName) Then
          blnRes = True
        Else
          MsgBox "Failed to open the tool " & strExecuteName, , "Error in ExecuteFile"
        End If
      End If
      
    End If
  End If
Finally:
  ExecuteFile = blnRes
End Function

Private Function UploadFromUserHome(ByVal strFullPathName As String, ByVal blnIsTestEnvironment As Boolean, Optional ByVal blnStripDownLoadExtension As Boolean = True) As Boolean
  Dim blnRes As Boolean
  Dim lngStripDownLoadExtension As Long
  Dim strUserHomeFile As String
  
  blnRes = False
  On Error GoTo Finally:
  If blnStripDownLoadExtension Then
    lngStripDownLoadExtension = Len(DSE_DOWNLOAD_EXTENSION3)
  Else
    lngStripDownLoadExtension = 0
  End If
  strUserHomeFile = GetUserHomeFile(strFullPathName, blnIsTestEnvironment, lngStripDownLoadExtension)
  blnRes = SharePointFileUpload(strUserHomeFile, strFullPathName)
Finally:
  UploadFromUserHome = blnRes
End Function

Public Function DownloadToUserHome(ByVal strFullPathName As String, ByVal blnIsTestEnvironment As Boolean, ByRef strFullPathNameUserHome As String, Optional ByVal blnStripDownLoadExtension As Boolean = True) As Boolean
  Dim blnRes As Boolean
  Dim lngStripDownLoadExtension As Long
  Dim strUserHome As String
  Dim strSep As String
  Dim strFileName As String
  Dim strTest As String
  Dim strUserHomeFile As String
  Dim objFSO As Object
  Dim i As Long
  
  blnRes = False
  On Error GoTo Finally:
  If blnStripDownLoadExtension Then
    lngStripDownLoadExtension = Len(DSE_DOWNLOAD_EXTENSION1)
  Else
    lngStripDownLoadExtension = 0
  End If
  strUserHomeFile = GetUserHomeFile(strFullPathName, blnIsTestEnvironment, lngStripDownLoadExtension)
  If DownloadFile(strFullPathName, strUserHomeFile) Then
    blnRes = True
    strFullPathNameUserHome = strUserHomeFile
  End If
  
Finally:
  Set objFSO = Nothing
  DownloadToUserHome = blnRes
End Function

Public Function GetUserHomeFile(ByVal strFullPathName As String, ByVal blnIsTestEnvironment As Boolean, ByVal lngStripDownLoadExtension As Long) As String
  Dim strRes As String
  Dim strUserHome As String
  Dim strSep As String
  Dim strFileName As String
  Dim strTest As String
  Dim objFSO As Object
  
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  strRes = ""
  strUserHome = GetUserHomePath()
  strSep = DetermineSeparator(strUserHome)
  strFileName = GetFileNameFromFullName(strFullPathName)
  If lngStripDownLoadExtension > 0 Then
    strFileName = Left(strFileName, Len(strFileName) - lngStripDownLoadExtension)
  End If
  strTest = IIf(blnIsTestEnvironment, strSep & "Test", "")
  strRes = AddSeparator(strUserHome, strSep) & DSE_APPLICATIONS_FOLDER
  If Not objFSO.FolderExists(strRes) Then objFSO.CreateFolder strRes
  strRes = strRes & strTest
  If Not objFSO.FolderExists(strRes) Then objFSO.CreateFolder strRes
  strRes = AddSeparator(strRes, strSep) & strFileName
  
  GetUserHomeFile = strRes
End Function

Private Function IsSP365File(ByVal strURL As String) As Boolean
  IsSP365File = (InStr(1, strURL, "msfintl.sharepoint.com", vbTextCompare) > 0)
End Function

Public Function DownloadFileBT(ByVal strURL As String, ByVal strFile As String) As Boolean
  Const adTypeBinary = 1
  Const adSaveCreateOverWrite = 2
  Dim blnRes As Boolean
  Dim varResponse As Variant
  Dim objStream As Object
  Dim objHTTPRequest As New XMLHTTP60
  Dim strErrorDescription As String
  
  'BIJ HET MISLUKKEN VAN DE DOWNLOAD WORDEN DE VOLGENDE SITUATIES AFGEVANGEN EN GEMELD AAN DE GEBRUIKER:
  '1. GEEN SP365 AANMELDING OF GEEN SINGLE-SIGN-ON, DE .SEND SCHIET DIRECT NAAR DE ERRORHANDLER.
  '2. GEEN RECHTEN OM EEN LOCATIE (ANDERS DAN SP365) TE BENADEREN, DE .SEND SCHIET DIRECT NAAR DE ERRORHANDLER.
  '3. ONVOLDOENDE RECHTEN OP SP365 (OF LOCATIE WAAR TOOL STAAT).
  '4. URL BESTAAT NIET OF IS NIET GEVONDEN.
  '5. TOOL IS REEDS (EN NOG STEEDS) GEOPEND EN KAN DAAROM NIET OVERSCHREVEN WORDEN.
  
  If IsSP365File(strURL) Then
    strErrorDescription = "You are not logged in at SharePoint365 or your connection is not set to 'Stay connected'." & _
      " First login to SharePoint and choose 'Stay connected'." & _
      " Than restart the setup tool."
  Else
    strErrorDescription = "You have insufficient rights to download the file from this location."
  End If
  blnRes = False
  On Error GoTo Finally:
  With objHTTPRequest
    .Open "GET", strURL, False
    .setRequestHeader "Content-type:", "text/xml"
    .setRequestHeader "Translate:", "f"
    .send 'WE BREAKEN HIER NAAR FINALLY IN BOVENGENOEMDE SITUATIES 1 EN 2.
    
    'Wachten tot downloaden gereed is
    Do While .ReadyState <> 4 'STATE = DONE
      DoEvents
    Loop
    varResponse = .ResponseBody
    strErrorDescription = ""
    If InStr(1, .statusText, "Not Found", vbTextCompare) > 0 Then
      strErrorDescription = "The requested file has not been found."
    Else
      If Len(.ResponseBody) > 0 Then
        blnRes = True
      Else
        strErrorDescription = "You have insufficient rights to download the file."
      End If
    End If
  End With
  
  If blnRes Then
    blnRes = False
    'Opslaan van download
    strErrorDescription = "The file has been downloaded but could not be saved."
    Set objStream = CreateObject("Adodb.Stream")
    With objStream
      .Type = adTypeBinary
      .Open
      .Write varResponse
      strErrorDescription = strErrorDescription & " Is the file already open?"
      .SaveToFile strFile, adSaveCreateOverWrite
      strErrorDescription = ""
      .Close
    End With
    blnRes = True
  End If
  
Finally:
  Set objStream = Nothing
  Set objHTTPRequest = Nothing
  If Len(strErrorDescription) > 0 Then
    MsgBox strErrorDescription & vbCrLf & "Failed to download the following file: " & strURL, , "Error in DownloadFile"
  End If
  DownloadFileBT = blnRes
End Function

Public Function MSAccessIsAvailable() As Boolean
   Dim blnRes As Boolean

   blnRes = ApplicationIsAvailable("Access.Application")
   If Not blnRes Then
     MsgBox "This tool only works when Microsoft Access can be referenced.", , "MSAccess reference needed"
   End If
   MSAccessIsAvailable = blnRes
End Function

Public Function ApplicationIsAvailable(ByVal strApplicationClassName As String) As Boolean
   Dim blnRes As Boolean
   Dim objApp As Object

   blnRes = False
   On Error GoTo Finally:
   Set objApp = CreateObject(strApplicationClassName)
   blnRes = Not (objApp Is Nothing)
   Set objApp = Nothing
Finally:
   ApplicationIsAvailable = blnRes
End Function

Attribute VB_Name = "modSHARED_CloseWorkBook"
Option Explicit

'LAATST_GEWIJZIGD: 2019_10_31
'DIT IS EEN ZOGENAAMDE "SHARED MODULE" DIE IN MEERDERE APPLICATIES IN (VRIJWEL) EXACT DEZELFDE VORM IS OPGENOMEN.
'LATEN WE PROBEREN OM DE SHARED MODULES ZO VEEL MOGELIJK UP-TO-DATE TE HOUDEN MET ELKAAR, BOVENSTAANDE LAATST_GEWIJZIGD
'DATUM DIENT TER ONDERSTEUNING HIERVAN.

Public Sub CloseWorkBook(ByRef wb As Workbook)
   On Error Resume Next
   If wb.Application.Workbooks.Count > 1 Then
     wb.Close False
   Else
     wb.Application.Quit
   End If
End Sub

Attribute VB_Name = "modTool"
Option Explicit

Public Const APPLICATION_VERSION = "0.9"
Public Const APPLICATION_NAME = "MSF OCA BT Setup"
Public Const APPLICATION_PASSWORD = "c7eyaFaz"
Public Const APPLICATION_MSACCESSPW = "c7eyaFaz"
Public Const DEVELOPMENT_MODUS = False

Private Const ROW_START_TEXT_ERROR = 7
Private Const ROW_END_TEXT_ERROR = 10
Private Const ROW_START_TEXT_CONTROLE = 11
Private Const ROW_END_TEXT_CONTROLE = 14
Private Const ROW_START_TEXT_BEZIG = 15
Private Const ROW_END_TEXT_BEZIG = 18
Private Const INI_FILE = "BT.ini"
Private Const ODBC_DRIVER_SQL_32 = "https://download.microsoft.com/download/6/b/3/6b3dd05c-678c-4e6b-b503-1d66e16ef23d/en-US/17.6.1.1/x86/msodbcsql.msi"
Private Const ODBC_DRIVER_SQL_64 = "https://download.microsoft.com/download/6/b/3/6b3dd05c-678c-4e6b-b503-1d66e16ef23d/en-US/17.6.1.1/x64/msodbcsql.msi"
Private Const MSF_INSTALL_FOLDER = "D:\MSF Data\"

Public Function CloseWorkBookNoSave()
  ThisWorkbook.Saved = True
  CloseWorkBook ThisWorkbook
End Function

Public Function GetUserDeskTopPath() As String
  Dim strRes As String
  Dim objFolders As Object
  
  strRes = ""
  On Error GoTo Finally:
  Set objFolders = CreateObject("WScript.Shell").SpecialFolders
  strRes = objFolders("desktop")
Finally:
  Set objFolders = Nothing
  GetUserDeskTopPath = strRes
End Function

Public Function YesNoMsg(ByVal s As String, Optional ByVal strCaption As String = "Vraag") As Boolean
  YesNoMsg = (MsgBox(s, vbYesNoCancel, strCaption) = vbYes)
End Function

Public Sub ShowHideInfo(ByVal blnShowError As Boolean, ByVal blnShowCheck As Boolean, ByVal blnShowBusy As Boolean)
  Dim blnProtected As Boolean
  
  blnProtected = wsInstall.ProtectContents
  If blnProtected Then wsInstall.Unprotect APPLICATION_PASSWORD
  wsInstall.Rows(ROW_START_TEXT_ERROR & ":" & ROW_END_TEXT_ERROR).Hidden = (Not blnShowError)
  wsInstall.Rows(ROW_START_TEXT_CONTROLE & ":" & ROW_END_TEXT_CONTROLE).Hidden = (Not blnShowCheck)
  wsInstall.Rows(ROW_START_TEXT_BEZIG & ":" & ROW_END_TEXT_BEZIG).Hidden = (Not blnShowBusy)
  If blnProtected Then wsInstall.Protect APPLICATION_PASSWORD
  DoEvents
End Sub

Private Sub ProtectSheet(ByRef ws As Worksheet)
  ws.Protect Password:=APPLICATION_PASSWORD, DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

Private Sub SetFocusDefault()
  ActiveSheet.Cells(2, 1).Select
End Sub

Public Function ToonAlles()
  Dim wsCurrent As Worksheet
  Dim ws As Worksheet
  
  Set wsCurrent = ActiveSheet
  Set ws = wsInstall
  Application.DisplayFormulaBar = True
  ws.Activate
  ws.Unprotect APPLICATION_PASSWORD
  ws.UsedRange.EntireRow.Hidden = False
  With ActiveWindow
    .DisplayHeadings = True
    .DisplayGridlines = True
    .DisplayHorizontalScrollBar = True
    .DisplayVerticalScrollBar = True
    .DisplayWorkbookTabs = True
  End With
  ShowHideInfo True, True, True
  SetFocusDefault
  wsCurrent.Activate
End Function

Public Function VerbergAlles()
  Dim wsCurrent As Worksheet
  Dim ws As Worksheet
  
  Set wsCurrent = ActiveSheet
  Set ws = wsInstall
  Application.DisplayFormulaBar = False
  ws.Activate
  With ActiveWindow
    .DisplayHeadings = False
    .DisplayGridlines = False
    .DisplayHorizontalScrollBar = False
    .DisplayVerticalScrollBar = False
    .DisplayWorkbookTabs = False
  End With
  ShowHideInfo True, False, False
  ProtectSheet ws
  SetFocusDefault
  wsCurrent.Activate
End Function

Public Function Opleveren()
  Const OPLEVER_BASIS_MAP = ""
  Dim strVorigeMap As String, strNieuweMap As String
  Dim strXLSName As String, strFileFormat As String
  
  '01 REALISEER DE TOOL-SPECIFIEKE OPLEVER-CONFIGURATIE:
  ToonAlles
  wsInstall.Range("N3") = "(" & APPLICATION_NAME & ", version " & APPLICATION_VERSION & ")"
  wsInstall.Activate
  
  '02 MAAK OP HET JUISTE MOMENT (ALS ER NOG GEEN OBJECTEN MET WACHTWOORDEN ZIJN AFGESCHERMD) DE CODEDUMP AAN:
  VBACodeDump
  
  '03 VERVOLG DE TOOL-SPECIFIEKE OPLEVER-CONFIGURATIE:
  VerbergAlles
  
  'TODO: aanpassen naar MSF
  ThisWorkbook.Save
  CloseWorkBook ThisWorkbook
  Exit Function
  
  '04 ZOEK DE MEEST RECENTE OPLEVERMAP EN MAAK EEN NIEUWE OPLEVERMAP AAN:
  strVorigeMap = ZoekNieuwsteOpleverMap(OPLEVER_BASIS_MAP, "")
  strNieuweMap = MaakOpleverMap(OPLEVER_BASIS_MAP, "", "Versie_" & APPLICATION_VERSION)
  
  '05 KOPIEER EN VERPLAATS ENKELE OPLEVER-HULPBESTANDEN VAN DE VORIGE OPLEVERMAP NAAR DE NIEUWE:
  FileCopy_FSO AddSeparator(strVorigeMap) & "WhatsNew.txt", AddSeparator(strNieuweMap) & "WhatsNew.txt"
  FileMove_FSO AddSeparator(strVorigeMap) & "CopyToolsToThisFolder.bat", AddSeparator(strNieuweMap) & "CopyToolsToThisFolder.bat"
  FileMove_FSO AddSeparator(strVorigeMap) & "UploadToolsToSharePoint.xlsm", AddSeparator(strNieuweMap) & "UploadToolsToSharePoint.xlsm"
  
  '06 BEWAAR DEZE TOOL EN SLUIT 'M AF:
  ThisWorkbook.Save
  strXLSName = RemoveFileExtension(ThisWorkbook.FullName) & ".xls"
  FileDelete_FSO strXLSName
  ThisWorkbook.SaveAs FileName:=strXLSName, FileFormat:=xlExcel8
  CloseWorkBook ThisWorkbook
End Function

Public Function DownLoadAndDeskTopShortCut(ByVal strSharePointAppPlazaFullName As String, ByRef strDownLoadFullName As String) As Boolean
  Dim blnRes As Boolean
  Dim strDeskTopAppPlazaShortCutFullName As String
  Dim appXL As Object
  Dim strExcelPath As String
  Dim strArguments
  
  'ApplicatiePlaza365_<environment>.xlsm wordt gedownload naar dit BYOD en in de DSE_Applications map van de user gezet.
  'Er wordt een Desktop-ShortCut op dit BYOD geplaatst die verwijst naar de lokale ApplicatiePlaza365_<environment>.xlsm.
  'Voordeel van deze Desktop-ShortCut: Er kan een custom icon en naam zonder technische extensie worden gebruikt.
  
  blnRes = False
  On Error GoTo Finally:
  
  Set appXL = CreateObject("Excel.Application")
  strExcelPath = appXL.Path
  appXL.Quit
  Set appXL = Nothing
  
  'DOWNLOAD DE TOOL NAAR DIT BYOD EN STEL DE DOWNLOAD-BEWAAR-NAAM VAN DE TOOL VAST:
  blnRes = DownloadToUserHome(strSharePointAppPlazaFullName, False, strDownLoadFullName)
  
  If blnRes Then
    'STEL NU DE DESKTOPNAAM VAN DE SHORTCUT SAMEN:
    strDeskTopAppPlazaShortCutFullName = AddSeparator(GetUserDeskTopPath()) & "OCA Budget Tool" & GetEnvironmentPostFix()
    'EN MAAK DE SHORTCUT AAN met Blue cake button:
    blnRes = CreateWindowsShortCut(strDeskTopAppPlazaShortCutFullName, _
      Application.Path & "\EXCEL.EXE", _
      "C:\Windows\System32\shell32.dll", 166, _
      "Developed by DSE Software", _
      """" & strDownLoadFullName & """ /x")
  End If
Finally:
  DownLoadAndDeskTopShortCut = blnRes
End Function

Public Function DeskTopShortCut(ByVal strFullName As String, Optional ByVal strTitle As String = "OCA Budget Tool") As Boolean
  Dim blnRes As Boolean
  Dim strDeskTopShortCutFullName As String
  Dim objExcel As Object
  Dim strExcelPath As String
  
  'Er wordt een Desktop-ShortCut op dit BYOD geplaatst die verwijst naar de lokale BT
  'Voordeel van deze Desktop-ShortCut: Er kan een custom icon en naam zonder technische extensie worden gebruikt.

  blnRes = False
  On Error GoTo Finally:

  'STEL NU DE DESKTOPNAAM VAN DE SHORTCUT SAMEN:
  strDeskTopShortCutFullName = AddSeparator(GetUserDeskTopPath()) & strTitle
  'EN MAAK DE SHORTCUT AAN met Blue cake button:
  blnRes = CreateWindowsShortCut(strDeskTopShortCutFullName, _
    Application.Path & "\EXCEL.EXE", _
    "C:\Windows\System32\shell32.dll", 166, _
    "Developed by DSE Software", _
    """" & strFullName & """ /x")
    
  'En maak ook een shortcut aan in de lokale folder
  blnRes = CreateWindowsShortCut(GetPathFromFullName(strFullName) & "\" & strTitle, _
    Application.Path & "\EXCEL.EXE", _
    "C:\Windows\System32\shell32.dll", 166, _
    "Developed by DSE Software", _
    """" & strFullName & """ /x")

Finally:
  DeskTopShortCut = blnRes
End Function

Public Function InitApplicatie() As Boolean
  Dim blnCloseDirectOrWithDelay As Boolean
  Dim blnCloseWithDelay As Boolean
  Dim wbThis As Workbook
  Dim strMsg As String, strAppShortName As String
  Dim strAppFullName As String, strDownLoadFullName As String, strAP365Omgeving As String, strInstallFolder As String
  Dim strDestinationFullName As String, strShortCutTitle As String, strMission As String, strProject As String
  Dim strTest As String, strErrorMessage As String, strODBCUrl As String, strGetFolder As String
  Dim rs As Object
  Dim objShell As Object
  Dim waitOnReturn As Boolean
  Dim windowStyle As Integer
  Dim objExcel As Excel.Application
  
  blnCloseDirectOrWithDelay = True
  
  'MAKE SURE THE TITLE BAR AND THE LOGO ARE DISPLAYED DURING STARTUP:
  ShowHideInfo False, True, False
    
  If CheckOfficeVersion() Then
    If Check365Connection(blnLogon365InternetExplorerIfNoConnection:=True) Then
      'Bepaal de laatste BT versie op SharePoint
      strAppFullName = GetLastVersionBTFullName()
      strAppShortName = RemoveFileExtension(GetFileNameFromFullName(strAppFullName))
      strAP365Omgeving = strAppShortName
      
      If Len(strAppFullName) > 0 Then
      
        If YesNoMsg("This will install " & strAP365Omgeving & ". Click Yes to continue and choose an installation folder.", "Installation MSF OCA Budget Tool") Then
      
          ShowHideInfo False, False, True
          Set wbThis = ThisWorkbook
          strMsg = ""

          'Vraag waar BT mag worden geïnstalleerd
          strGetFolder = GetFolder("Choose your folder where & " & strAppShortName & " will be installed", MSF_INSTALL_FOLDER)
          If Len(strGetFolder) > 0 Then
            strInstallFolder = GetInstallFolder(strGetFolder & "\OCA-BT")
            CreateFolder_FSO strInstallFolder

            strDestinationFullName = strInstallFolder & "\" & GetFileNameFromFullName(strAppFullName)
            If Right(GetFileExtension(strDestinationFullName, "\", True), 4) = DSE_DOWNLOAD_EXTENSION1 Then
              strDestinationFullName = Left(strDestinationFullName, Len(strDestinationFullName) - 4)
            End If
            'Indien BT bestaat met dezelfde naam, check of BT open is want we gaan deze overschrijven
            If IsFileOpen(strDestinationFullName, False) = True Then
              strMsg = strAP365Omgeving & " could not be installed. Please close BT or choose a different folder. Installation is cancelled."
            Else
              'indien gesloten verschuif de huidige BT naar de lokale backup/archief map
              If FileExists(strDestinationFullName) Then
                'Create local backups directory if not exists
                If CreateFolder_FSO(strInstallFolder & "\backups") Or FolderExists_FSO(strInstallFolder & "\backups") Then
                  FileMove_FSO strInstallFolder & "\" & GetFileNameFromFullName(strDestinationFullName), _
                    strInstallFolder & "\backups\" & GetFileNameFromFullName(strDestinationFullName) & Format(Date + Time(), "_yyyy_mm_dd_hh_mm_ss")
                Else
                  strMsg = strAP365Omgeving & " could not be archived."
                End If
              End If
              
              'TODO voor BT: vraag de gebruiker of oude versies van BT verhoven mogen worden naar backup/archief map
              If DownloadFileBT(strAppFullName, strDestinationFullName) Then
              
                'Download BT.accdb als deze nog niet bestaat
                If Not FileExists(strInstallFolder & "\data\BT.accdb") Then
                  If CreateFolder_FSO(strInstallFolder & "\data") Or FolderExists_FSO(strInstallFolder & "\data") Then
                    If Not DownloadFileBT(SharePointHQFolder() & RELEASE_FOLDER & "BT.accdb", strInstallFolder & "\data\BT.accdb") Then
                      strMsg = "Local access database for BT could not be installed."
                    ElseIf Not IsLiveEnvironment() Then
                      DownloadFileBT SharePointHQFolder() & RELEASE_FOLDER & "BT.accdb", strInstallFolder & "\data\BT_test.accdb"
                    End If
                  End If
                End If
                                                
                'Open de nieuwe BT en sluit hierna de Setup tool
                AsyncShell """" & Application.Path & "\excel.exe"" /x """ & strDestinationFullName & """"
              Else
                strMsg = strAP365Omgeving & " could not be downloaded. Installation has failed."
              End If
            End If
          Else
            strMsg = "No installation folder chosen. Installation aborted."
          End If
        Else
          'no message
        End If
      Else
        strMsg = "No BT versions found, or no access to release folder. Installation aborted."
      End If
    End If
  End If
  
  If Len(strMsg) > 0 Then
    MsgBox strMsg, vbInformation, strAP365Omgeving
  End If
  CloseWorkBookNoSave
  
End Function

Public Function StartApplicatie() As Boolean
  InitApplicatie
End Function

Private Function GetPlazaPlusFullName() As String
  Dim strRes As String
  Dim rs As ADODB.Recordset
  
  strRes = ""
  On Error GoTo Finally:
  If VerifyDBToegang(GetDataBaseName()) Then
    Set rs = New ADODB.Recordset
    rs.Open "select * from PlazaPlusConfig", g_objConnection, adOpenForwardOnly, adLockReadOnly
    If Not rs.EOF Then
      strRes = VeldToStr(rs!ClientFullName)
    End If
    rs.Close
    Set rs = Nothing
  End If
Finally:
  GetPlazaPlusFullName = strRes
End Function

Private Function VeldToStr(varVeld As Variant) As String
  Dim strRes As String
  
  strRes = ""
  On Error GoTo Finally:
  strRes = varVeld
Finally:
  VeldToStr = strRes
End Function

Public Function GetLastVersionBTFullName() As String
  Dim strFolder As String
  Dim saFolders() As String, saFiles() As String, saFileDateTimeModified() As String
  
  strFolder = SharePointHQFolder() & RELEASE_FOLDER
  If SharePointGetFoldersAndFiles(strFolder, saFolders(), saFiles(), saFileDateTimeModified(), "LinkFilename", "FALSE", "Modified", "FALSE", "OCA-BT", ".xlsm_dse") Then
    'check op geen resultaat of lege folder
    If Not StringArrayEmpty(saFiles) Then
      GetLastVersionBTFullName = strFolder & saFiles(0)
    End If
  End If
End Function

Public Function GetFolder(Optional ByVal strTitle As String = "Select a Folder", Optional ByVal strDefaultFolder As String) As String
    Dim objFileDialog As FileDialog
    Dim strItem As String
    Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    With objFileDialog
        .TITLE = strTitle
        .AllowMultiSelect = False
        .InitialFileName = IIf(Len(strDefaultFolder) = 0, Application.DefaultFilePath, strDefaultFolder)
        If .Show <> -1 Then GoTo NextCode
        strItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = strItem
    Set objFileDialog = Nothing
End Function

Public Function IsFileOpen(FileName As String, Optional ResultOnBadFile As Variant) As Variant
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  ' IsFileOpen
  ' This function determines whether a the file named by FileName is
  ' open by another process. The fuction returns True if the file is open
  ' or False if the file is not open. If the file named by FileName does
  ' not exist or if FileName is not a valid file name, the result returned
  ' if equal to the value of ResultOnBadFile if that parameter is provided.xd
  ' If ResultOnBadFile is not passed in, and FileName does not exist or
  ' is an invalid file name, the result is False.
  ' http://www.cpearson.com/excel/IsFileOpen.aspx
  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  
  Dim FileNum As Integer
  Dim ErrNum As Integer
  Dim V As Variant
  
  On Error Resume Next
  
  ''''''''''''''''''''''''''''''''''''''''''''
  ' If we were passed in an empty string,
  ' there is no file to test so return FALSE.
  ''''''''''''''''''''''''''''''''''''''''''''
  If Trim(FileName) = vbNullString Then
      If IsMissing(ResultOnBadFile) = True Then
          IsFileOpen = False
      Else
          IsFileOpen = ResultOnBadFile
      End If
      Exit Function
  End If
  
  ''''''''''''''''''''''''''''''''''''''''''''
  ' if the file doesn't exist, it isn't open
  ' so get out now
  ''''''''''''''''''''''''''''''''''''''''''''
  V = Dir(FileName, vbNormal)
  If IsError(V) = True Then
      ' syntactically bad file name
      If IsMissing(ResultOnBadFile) = True Then
          IsFileOpen = False
      Else
          IsFileOpen = ResultOnBadFile
      End If
      Exit Function
  ElseIf V = vbNullString Then
      ' file doesn't exist.
      If IsMissing(ResultOnBadFile) = True Then
          IsFileOpen = False
      Else
          IsFileOpen = ResultOnBadFile
      End If
      Exit Function
  End If
  
  FileNum = FreeFile()
  '''''''''''''''''''''''''''''''''''''''
  ' Attempt to open the file and lock it.
  '''''''''''''''''''''''''''''''''''''''
  Err.Clear
  Open FileName For Input Lock Read As #FileNum
  ErrNum = Err.Number
  ''''''''''''''''''''
  ' Close the file.
  ''''''''''''''''''''
  Close FileNum
  On Error GoTo 0
  
  ''''''''''''''''''''''''''''''''''''''
  ' Check to see which error occurred.
  ''''''''''''''''''''''''''''''''''''''
  Select Case ErrNum
      Case 0
          ''''''''''''''''''''''''''''''''''''''''''''
          ' No error occurred.
          ' File is NOT already open by another user.
          ''''''''''''''''''''''''''''''''''''''''''''
…