Malicious Office (OLE) — 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

Public Property Get ConnectorApplication() As Object
  Set ConnectorApplication = IDLDecentralEntry.IntApplication
End Property

Public Property Get IDLAddinManager() As Object
  Set IDLAddinManager = IDLDecentralEntry.IDLAddinManager
End Property


Private Sub Workbook_AddinInstall()
  IDLDecentralEntry.Auto_Open
End Sub



Public Sub OpenConnectorWorkbook()
  IDLDecentralEntry.OpenConnectorWorkbook
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 = "frmFormats"
Attribute VB_Base = "0{D935C083-096F-4F05-9559-647349734243}{DC2EC8BD-8B24-45FF-A08D-4F31B1A062D3}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False



Option Explicit

Private Sub cbCancel_Click()
  Unload Me
End Sub

Private Sub cbOK_Click()
  On Error GoTo ErrHandler
  
  ApplyChanges
  Unload Me
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
End Sub

Private Sub ApplyChanges()
  Dim rActive As Range
  Dim oInternalApplication As Object
  Dim nIndex As Long, nCount As Long
  Dim vntTemp As Variant
  Dim oFrmLineDiff As New frmLineDiff
  
  Set oInternalApplication = ConnectorApplication.InternalApplication
  
  nIndex = lstFormats.ListIndex
  If nIndex >= 0 Then
    Set rActive = ActiveCell
    If Not rActive Is Nothing Then
    
      oInternalApplication.Profile_Read "Format." & nIndex & ".Type", vntTemp
#If SUPPORT_EXCEL97 = 0 Then
      Debug.Assert vntTemp = "LineDiff"
#End If
      oFrmLineDiff.InitFromSelection bOverwriteExistingFormat:=True
      oInternalApplication.Profile_Read "Format." & nIndex & ".Members", vntTemp
      oFrmLineDiff.LoadFromStringParameters vntTemp
      oFrmLineDiff.ApplyChanges

    End If
  End If
  
End Sub


Public Sub Init()
  Dim oInternalApplication As Object
  Dim i As Long, nCount As Long
  Dim vntTemp As Variant
  
  Set oInternalApplication = ConnectorApplication.InternalApplication
  
  Caption = oInternalApplication.LocText_FindByID(406) 'Formate
  cbOK.Caption = oInternalApplication.LocText_FindByID(412)  'Einfügen
  cbCancel.Caption = oInternalApplication.LocText_FindByID(23) 'Abbrechen
  cbCopy.Caption = oInternalApplication.LocText_FindByID(413) 'Kopieren
  cbDelete.Caption = oInternalApplication.LocText_FindByID(414) 'Löschen
  cbRename.Caption = oInternalApplication.LocText_FindByID(360) 'Unbenennen

  
  oInternalApplication.Profile_Read "Format.Count", vntTemp
  If IsNumeric(vntTemp) Then
    nCount = CLng(vntTemp)
  End If
  lstFormats.Clear
  For i = 0 To nCount - 1
    oInternalApplication.Profile_Read "Format." & i & ".Name", vntTemp
    lstFormats.AddItem vntTemp
  Next i
  If nCount > 0 Then
    lstFormats.Selected(0) = True
  Else
    cbOK.Enabled = False
  End If
  
End Sub

Public Sub RunModal()
  Show
End Sub


Attribute VB_Name = "frmLineDiff"
Attribute VB_Base = "0{78754338-BE8A-4612-B46B-8EB852437017}{57D5D8CB-D4A3-4B93-BB04-7F19AAE72924}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False



Option Explicit

Private m_bSystemChange As Boolean
Private m_rSelection As Range

Private Sub cbCancel_Click()
  Unload Me
End Sub

Private Sub cbOK_Click()
  On Error GoTo ErrHandler
  ApplyChanges
  Unload Me
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub

#If SUPPORT_EXCEL97 Then
Public Sub ApplyChanges()
#Else
Friend Sub ApplyChanges()
#End If
  Dim r As Range
  Dim bHasArray As Boolean
  If IsNull(m_rSelection.HasArray) Then
    bHasArray = True
  Else
    bHasArray = m_rSelection.HasArray
  End If
  If bHasArray Then
    Set r = Nothing
    On Error Resume Next
    'bei zusammengesetzten Bereichen u.U. nicht festgelegt
    Set r = m_rSelection.CurrentArray 'wichtig: falls bereits ein Array zugeordnet: diese Löschen, falls Bereiche inkompatibel
    On Error GoTo 0
    If Not r Is Nothing Then
      r.FormulaArray = ""
    End If
  End If
  m_rSelection.FormulaArray = Application.ConvertFormula(CreateFormula(bSaveParams:=False), xlA1, xlR1C1, RelativeTo:=m_rSelection)
End Sub

'bOverwriteExistingFormat true: evt vorhandenes Format überschreiben
'bExistingOnly: nur prüfen, ob geeigneter Connector-Bezug: Rückgabe true
#If SUPPORT_EXCEL97 Then
Public Function Init(Optional ByVal bOverwriteExistingFormat As Boolean, Optional bExistingOnly As Boolean)
#Else
Friend Function Init(Optional ByVal bOverwriteExistingFormat As Boolean, Optional bExistingOnly As Boolean)
#End If
  Dim i As Long
  Dim nColumnMe As Long
  Dim vntArrayFormula As Variant
  Dim r As Range
  Dim oInternalApplication As Object
  
  On Error GoTo ErrHandler
    
  m_bSystemChange = True
  
  Set oInternalApplication = ConnectorApplication.InternalApplication
  
  Caption = oInternalApplication.LocText_FindByID(407) 'Zeilenunterschied
  cbOK.Caption = oInternalApplication.LocText_FindByID(22) 'OK
  cbCancel.Caption = oInternalApplication.LocText_FindByID(23) 'Abbrechen
  lblColumn.Caption = oInternalApplication.LocText_FindByID(411) 'Spalte
  lblcmbCompareOption.Caption = oInternalApplication.LocText_FindByID(415) 'Bedingung zu nachfolgender Zeile
  cbSaveAs.Caption = oInternalApplication.LocText_FindByID(340) 'Speichern unter ...
  
  
  If Not m_rSelection Is Nothing And (Not bOverwriteExistingFormat Or bExistingOnly) Then
    vntArrayFormula = m_rSelection.FormulaArray
    If IsNull(vntArrayFormula) Then
      Set r = Nothing
      'speziell antesten, ob CurrentArray bei gemischtem Bereich ermittelbar
      On Error Resume Next
      Set r = m_rSelection.CurrentArray
      On Error GoTo ErrHandler
      If r Is Nothing Then
        vntArrayFormula = Empty
      Else
        Set m_rSelection = r
        vntArrayFormula = m_rSelection.FormulaArray
      End If
    Else
      If InStr(1, vntArrayFormula, "IDLLineDiff", vbTextCompare) <= 0 Then
        vntArrayFormula = Empty
      End If
    End If
  End If
  If bExistingOnly And IsEmpty(vntArrayFormula) Then
    m_bSystemChange = False
    Exit Function
  End If


  cmbCompareOption.Clear
  cmbCompareOption.AddItem oInternalApplication.LocText_FindByID(416) 'Keine Restriktion
  cmbCompareOption.AddItem oInternalApplication.LocText_FindByID(417) 'Werte Identisch
  cmbCompareOption.AddItem oInternalApplication.LocText_FindByID(418) 'Werte Ungleich
  cmbCompareOption.ListIndex = 0
  
  If m_rSelection Is Nothing Then
    nColumnMe = -1
  Else
    nColumnMe = m_rSelection.Column
  End If
  
  cmbColumn.Clear
  For i = 1 To 256
    If i <> nColumnMe Then
      cmbColumn.AddItem ColumnNameFromIndex(i)
    End If
  Next i
  
  If Not IsEmpty(vntArrayFormula) Then
    Set g_frmLineDiffInit = Me
    Application.Evaluate Mid$(vntArrayFormula, 2) 'Testlauf, um Parameter zu erfahren
    Set g_frmLineDiffInit = Nothing
    Set m_rSelection = m_rSelection.CurrentArray 'Auswahl nun gesamtes Array
  End If
  
  m_bSystemChange = False
  If lstLineDiff.ListCount > 0 Then
    lstLineDiff.Selected(0) = True
    RefreshQuickEditFromSelection
  End If
  Init = True
  Exit Function
  
ErrHandler:
#If SUPPORT_EXCEL97 = 0 Then
  Debug.Assert False
#End If
  m_bSystemChange = False
  Err.Raise Err.Number, Err.Source, Err.Description
  
End Function

#If SUPPORT_EXCEL97 Then
Public Sub RunModal()
#Else
Friend Sub RunModal()
#End If
  Show
End Sub

'bExistingOnly: nur zeigen, falls geeigneter Connector-Bezug: Rückgabe true
#If SUPPORT_EXCEL97 Then
Public Function InitFromSelection(Optional ByVal rSelected As Range, Optional ByVal bOverwriteExistingFormat As Boolean, Optional bExistingOnly As Boolean) As Boolean
#Else
Friend Function InitFromSelection(Optional ByVal rSelected As Range, Optional ByVal bOverwriteExistingFormat As Boolean, Optional bExistingOnly As Boolean) As Boolean
#End If
  Dim nColumn As Long

  If rSelected Is Nothing Then
    Set rSelected = Selection
  End If
  Set rSelected = rSelected.Resize(ColumnSize:=1)
  If Not rSelected Is Nothing Then
    nColumn = rSelected.Column
    If (rSelected.count = 1 Or rSelected.count = 65536) And Not bExistingOnly Then
      'Bereich wird direkt gesucht, falls einzelne Zelle oder gesamte Spalte gewählt
      If rSelected.count = 1 Then
        'einzelne Zelle markiert den oberen Beginn
        Set rSelected = rSelected.Resize(RowSize:=65536 - rSelected.Row + 1)
      End If
      Set rSelected = Intersect(rSelected.Worksheet.UsedRange.EntireRow, rSelected)
    End If
  End If
  Set m_rSelection = rSelected
  
  InitFromSelection = Init(bOverwriteExistingFormat, bExistingOnly)

End Function

Private Sub cbSaveAs_Click()
  On Error GoTo ErrHandler
  
  SaveAs
  
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub

Private Sub SaveAs()
  Dim strName As String
  Dim oInternalApplication As Object
  Dim nCount As Long
  Dim vntTemp As Variant
  Dim i As Long
  Set oInternalApplication = ConnectorApplication.InternalApplication
  Do
    strName = InputBox("Geben Sie den Namen für die neue Formatdefinition an", "Speichern unter", Default:=strName)
    If strName = "" Then
      Exit Do
    Else
      oInternalApplication.Profile_Read "Format.Count", vntTemp
      If IsNumeric(vntTemp) Then
        nCount = CLng(vntTemp)
      End If
      
      For i = 0 To nCount - 1
        oInternalApplication.Profile_Read "Format." & i & ".Name", vntTemp
        If StrComp(vntTemp, strName, vbTextCompare) = 0 Then
          MsgBox "Name " & strName & " existiert bereits"
          GoTo ContinueDo
        End If
      Next i
      oInternalApplication.Profile_Write "Format." & nCount & ".Name", strName
      oInternalApplication.Profile_Write "Format." & nCount & ".Type", "LineDiff"
      oInternalApplication.Profile_Write "Format." & nCount & ".Members", CreateFormula(bSaveParams:=True)
      oInternalApplication.Profile_Write "Format.Count", nCount + 1
      Exit Do
    End If
ContinueDo:
  Loop
End Sub


Private Function Split_VBA5(ByVal Expression As String, ByRef Delimiter As Variant) As Variant
  Dim arSplit() As String
  Dim i As Long
  Dim nCount As Long
  Dim strTemp As String
  Do
    ReDim Preserve arSplit(nCount)
    i = InStr(1, Expression, Delimiter)
    If i > 0 Then
      arSplit(nCount) = Left$(Expression, i - 1)
      Expression = Mid$(Expression, i + 1)
      nCount = nCount + 1
    Else
      arSplit(nCount) = Expression
      nCount = nCount + 1
      Exit Do
    End If
  Loop
  If nCount > 0 Then
    Split_VBA5 = arSplit
  End If

End Function


'anhand von Parameterliste laden (Format laut Profil)
#If SUPPORT_EXCEL97 Then
Public Sub LoadFromStringParameters(ByVal strMembers As String)
#Else
Friend Sub LoadFromStringParameters(ByVal strMembers As String)
#End If
  Dim i As Long
  Dim bOk As Boolean
  Dim nCountRows As Long
  Dim nCountSrcColumns As Long
  Dim bEqualPrev As Boolean
#If SUPPORT_EXCEL97 Then
  Dim arMembers As Variant
#Else
  Dim arMembers() As String
#End If
  Dim strActMember As String
  
  m_bSystemChange = True
  lstLineDiff.Clear
  
#If SUPPORT_EXCEL97 Then
  arMembers = Split_VBA5(strMembers, ",")
#Else
  arMembers = Split(strMembers, ",")
#End If
  
  bEqualPrev = True 'Default
  For i = 0 To UBound(arMembers)
    bOk = False
    strActMember = Trim$(arMembers(i))
    'nach einer Spaltenangabe (oder bei erstem Aufruf): Überprüfen, ob Bedingungsoperator
    If strActMember = "=" Then
      bOk = True
      bEqualPrev = True
    ElseIf strActMember = "<>" Then
      bEqualPrev = False
      bOk = True
    End If
    If Not bOk Then
      'noch nicht bearbeitet, dann muss Spaltendef vorliegen
      lstLineDiff.AddItem strActMember
      If bEqualPrev Then
        lstLineDiff.List(nCountSrcColumns, 1) = cmbCompareOption.List(1)
      Else
        lstLineDiff.List(nCountSrcColumns, 1) = cmbCompareOption.List(2)
      End If
      nCountSrcColumns = nCountSrcColumns + 1

      bEqualPrev = True 'Default Equal
      
    End If
  Next i
  m_bSystemChange = False
End Sub

#If SUPPORT_EXCEL97 Then
Public Sub LoadFromParameters(ByVal nCountColumns As Long, nColumn() As Long, bEqualCondition() As Boolean)
#Else
Friend Sub LoadFromParameters(ByVal nCountColumns As Long, nColumn() As Long, bEqualCondition() As Boolean)
#End If
  Dim i As Long
  lstLineDiff.Clear

  For i = 0 To nCountColumns - 1

    lstLineDiff.AddItem ColumnNameFromIndex(nColumn(i))
    If bEqualCondition(i) Then
      lstLineDiff.List(i, 1) = cmbCompareOption.List(1)
    Else
      lstLineDiff.List(i, 1) = cmbCompareOption.List(2)
    End If
  Next i
End Sub

Private Sub cmbColumn_Click()
  On Error GoTo ErrHandler
  OnCmbClick 0
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub

Private Sub cmbCompareOption_Click()

  On Error GoTo ErrHandler
  OnCmbClick 1
  
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub


Private Sub lstLineDiff_Change()
  On Error GoTo ErrHandler

  RefreshQuickEditFromSelection
  
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub

Private Sub lstLineDiff_Click()
  On Error GoTo ErrHandler

  If m_bSystemChange Then Exit Sub
  RefreshQuickEditFromSelection
  
  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub

'liefert die Formel im A1 Stil (bSaveParams = false)
'ansonsten Parameter zum Speichern in Profil
#If SUPPORT_EXCEL97 Then
Public Function CreateFormula(ByVal bSaveParams As Boolean) As String
#Else
Friend Function CreateFormula(ByVal bSaveParams As Boolean) As String
#End If
  Dim nIndex As Long
  Dim strFormula As String
  Dim strColumn As String
  Dim strRange As String
  Dim nStartRow As Long
  Dim nEndRow As Long
  
  
  If Not bSaveParams Then
    If Not m_rSelection Is Nothing Then
      nStartRow = m_rSelection.Row
      nEndRow = nStartRow + m_rSelection.count - 1
    End If
    strFormula = "=IDLLineDiff("
  End If
  
  For nIndex = 0 To lstLineDiff.ListCount - 1
    If nIndex > 0 Then
      strFormula = strFormula & ","
    End If
    strColumn = lstLineDiff.List(nIndex, 0)
    If lstLineDiff.List(nIndex, 1) = ConnectorApplication.InternalApplication.LocText_FindByID(418) Then 'Werte Ungleich
      If bSaveParams Then
        strFormula = strFormula & "<>,"
      Else
        strFormula = strFormula & """<>"","
      End If
    End If
    If bSaveParams Then
      strRange = strColumn
    ElseIf nStartRow > 0 Then
      'mit Bezug:
      'genaue Angabe des Eingabereichs, damit automatische Aktualisierung gewährleistet
      strRange = strColumn & nStartRow & ":" & strColumn & nEndRow
    Else
      strRange = """" & strColumn & """" 'kein Bezug: nur Konstante für Spalte
    End If
    strFormula = strFormula & strRange
  Next nIndex
  If Not bSaveParams Then
    strFormula = strFormula & ")"
  End If
  CreateFormula = strFormula
End Function

Private Sub OnCmbClick(ByVal nIndex As Long)
  Dim nIndexListAct As Long
  Dim bNew As Boolean
  Dim strName As String
  Dim i As Long
  
  If m_bSystemChange Then Exit Sub
  
  m_bSystemChange = True
  nIndexListAct = lstLineDiff.ListIndex
  
  strName = cmbColumn
  
  bNew = True
  
  For i = 0 To lstLineDiff.ListCount - 1
    If strName < lstLineDiff.List(i, 0) Then
      Exit For
    ElseIf strName = lstLineDiff.List(i, 0) Then
      bNew = False
      Exit For
    End If
  Next i
  If i = lstLineDiff.ListCount Then
    bNew = True
  End If
  nIndexListAct = i
  If nIndex = 0 Then
    'Klick auf Column
    If bNew Then
      If cmbCompareOption.ListIndex <= 0 Then
        cmbCompareOption.ListIndex = 1
      End If
    Else
      cmbCompareOption = lstLineDiff.List(nIndexListAct, 1)
    End If
  ElseIf nIndex = 1 Then
    'Klick auf Bedingung
    If Not bNew Then
      If cmbCompareOption.ListIndex <= 0 Then
        'Eintrag löschen
        lstLineDiff.RemoveItem i
        If nIndexListAct >= lstLineDiff.ListCount Then
          nIndexListAct = lstLineDiff.ListCount - 1
        End If
        If nIndexListAct >= 0 Then
          lstLineDiff.ListIndex = nIndexListAct
          cmbColumn = lstLineDiff.List(nIndexListAct, 0)
          cmbCompareOption = lstLineDiff.List(nIndexListAct, 1)
        End If
      Else
        'Option ändern
        lstLineDiff.List(nIndexListAct, 1) = cmbCompareOption
      End If
    End If
  End If
  
  If bNew Then
    lstLineDiff.AddItem cmbColumn, nIndexListAct
    lstLineDiff.List(nIndexListAct, 1) = cmbCompareOption
  End If
  
  If nIndexListAct >= 0 And nIndexListAct < lstLineDiff.ListCount Then
    lstLineDiff.Selected(nIndexListAct) = True
  End If
  
  
  
  
  m_bSystemChange = False
  
End Sub

Private Function ColumnNameFromIndex(ByVal nColumn As Long) As String
  Dim strTemp As String
  Dim iFound As Long
  strTemp = Mid$(Application.ConvertFormula("C" & nColumn, xlR1C1, xlA1), 2) 'ohne $
  iFound = InStr(1, strTemp, ":")
  ColumnNameFromIndex = Left$(strTemp, iFound - 1)
End Function


Private Sub RefEdit1_Change()
  Dim r As Range
  On Error GoTo ErrHandler
  
  If m_bSystemChange Then Exit Sub
  
  On Error Resume Next
  Set r = Range(RefEdit1.Text)
  cmbColumn.Text = ColumnNameFromIndex(r.Column)
  RefEdit1.Text = ""

  Exit Sub
  
ErrHandler:
  MsgBox Err.Description, vbCritical
  
End Sub

Private Sub RefreshQuickEditFromSelection()
  Dim nIndex As Long
  Dim vnt As Variant
  If m_bSystemChange Then Exit Sub
  m_bSystemChange = True

  nIndex = lstLineDiff.ListIndex
  vnt = lstLineDiff.List(nIndex, 0)
  If vnt <> "" Then
    cmbColumn.Text = vnt
  End If
  vnt = lstLineDiff.List(nIndex, 1)
  If vnt <> "" Then
    cmbCompareOption.Text = vnt
  End If
  m_bSystemChange = False
  
End Sub


Attribute VB_Name = "IDLAddinManager"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit

'Klasse verwaltet IDL Addins

'ausserhalb Kvd201.dll: Ergänzung zu IDLDecentralEntry
'stellt dann Objektzugriff auf Elemente aus IDLDecentralEntry dar

Private m_LoadedAddins As New Collection 'Menge an Addins, die in unseren Besitz sind, nicht dabei diejenigen Addins, die eigenen Makrolader (GetIDLAddin besitzen)

Private WithEvents m_app As Application 'Ereignis-senke für Excel Ereignisse
Attribute m_app.VB_VarHelpID = -1

Private m_bSpreadApp As Boolean

#If Win64 Then
Private m_hProcessIdSpreadApp As LongPtr
#Else
Private m_hProcessIdSpreadApp As Long
#End If
 Private m_dwThreadIdSpreadApp As Long

Private m_bInprocConnector As Boolean 'true, falls Connector Inprozess aktiv

Private m_nAppisolation As Long

Private m_CommandArgs() As String

#If Win64 Then
Private Declare PtrSafe Function GetProcAddressLong Lib "Kernel32" Alias "GetProcAddress" (ByVal hModule As LongPtr, ByVal lpProcID As LongPtr) As LongPtr

Private Declare PtrSafe Function GetCurrentThreadId Lib "Kernel32" () As Long


Private Declare PtrSafe Function CreateProcessW Lib "kernel32" (ByVal pApplicationName As LongPtr, ByVal lpCommandLine As Longptr, ByVal lpProcessAttributes As Longptr, ByVal lpThreadAttributes As LongPtr, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As LongPtr, ByVal lpCurrentDirectory As LongPtr, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare PtrSafe Function PostThreadMessageA Lib "user32" (ByVal idThread As Long, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long

Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long


Private Type PROCESS_INFORMATION
  hProcess As LongPtr
  hThread As LongPtr
  dwProcessId As Long
  dwThreadId As Long
End Type


Private Type STARTUPINFO
  cb As Long
  lpReserved As LongPtr
  lpDesktop As LongPtr
  lpTitle As LongPtr
  dwX As Long
  dwY As Long
  dwXSize As Long
  dwYSize As Long
  dwXCountChars As Long
  dwYCountChars As Long
  dwFillAttribute As Long
  dwFlags As Long
  wShowWindow As Integer
  cbReserved2 As Integer
  lpReserved2 As LongPtr
  hStdInput As LongPtr
  hStdOutput As LongPtr
  hStdError As LongPtr
End Type



#Else
Private Declare Function GetProcAddressLong Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcID As Long) As Long


Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long


Private Declare Function CreateProcessW Lib "kernel32" (ByVal pApplicationName As Long, ByVal lpCommandLine As Long, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function PostThreadMessageA Lib "user32" (ByVal idThread As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long


Private Type PROCESS_INFORMATION
  hProcess As Long
  hThread As Long
  dwProcessId As Long
  dwThreadId As Long
End Type


Private Type STARTUPINFO
  cb As Long
  lpReserved As Long
  lpDesktop As Long
  lpTitle As Long
  dwX As Long
  dwY As Long
  dwXSize As Long
  dwYSize As Long
  dwXCountChars As Long
  dwYCountChars As Long
  dwFillAttribute As Long
  dwFlags As Long
  wShowWindow As Integer
  cbReserved2 As Integer
  lpReserved2 As Long
  hStdInput As Long
  hStdOutput As Long
  hStdError As Long
End Type




#End If

Public Sub initSpreadApp()
  m_bSpreadApp = True
End Sub

Public Sub notifyInprocConnector()
  m_bInprocConnector = True
End Sub

Public Property Get isInprocConnector() As Boolean
  isInprocConnector = m_bInprocConnector
End Property
#If Win64 = 0 Then


Public Function LoadDllModule(ByVal FullPath As String, Optional ByVal Context As Object) As Object
  If IDLDecentralEntry.isMemLoadDll Then
    Set LoadDllModule = LoadDllModuleMem(FullPath, Context)
  Else
    Set LoadDllModule = LoadDllModuleDirect(FullPath, Context)
  End If
End Function


'lädt registrierungsfreies Dll Modul-Objekt, gemäss Standard Signatur für registrierungsfreie Module
Public Function LoadDllModuleDirect(ByVal FullPath As String, Optional ByVal Context As Object) As Object
  Dim hr As Long
  Dim oTemp As Object
  Dim strError As String
  Dim nError As Long
  Dim hModule As Long
  Dim pFct As Long
  Dim oModule As Object
  Const EXPORT_ORDINAL_INITMODULE = 40000
  
  verifySystemVersion
  InitFctPtrStub
        
  On Error GoTo ErrHandler
  
  If isWin32Unicode Then
    hModule = LoadLibraryW(StrPtr(FullPath))
  Else
    hModule = LoadLibraryA(FullPath)
  End If
  If hModule = 0 Then RaiseWinError Err.LastDllError, FullPath
    
  pFct = GetProcAddressLong(hModule, EXPORT_ORDINAL_INITMODULE)
  If pFct = 0 Then
    RaiseWinError Err.LastDllError, FullPath & ".InitModule"
  Else
    hr = PtrFct4(pFct, 0, ObjPtr(Context), VarPtr(oModule), VarPtr(strError))
    If hr < 0 Then
      RaiseWinError hr, strError
    End If
  End If
  
Cleanup:
  If hModule <> 0 Then
    FreeLibrary hModule
    hModule = 0
  End If
  If nError <> 0 Then
    On Error GoTo 0
    Err.Raise nError, , strError
  End If
  
  Set LoadDllModuleDirect = oModule
  
  Exit Function
ErrHandler:
  nError = Err.Number
  strError = Err.Description
  On Error Resume Next
  
  'Fehlernummer hinzufügen
  If nError < 0 Then
    strError = strError & vbLf & "Error=" & Hex(nError)
  Else
    strError = strError & vbLf & "Error=" & nError
  End If
  
  GoTo Cleanup
End Function

'lädt registrierungsfreies Dll Modul-Objekt, gemäss Standard Signatur für registrierungsfreie Module
'Implementation für In Memory Loader
Public Function LoadDllModuleMem(ByVal FullPath As String, Optional ByVal Context As Object) As Object
  Dim oTemp As Object
  Dim strError As String, nError As Long
  Dim oModule As Object
  Dim r As Range
  
  Dim pBuffer As Long, dwSize As Long, dwRead As Long, hFile As Long
  
  Const INVALID_HANDLE_VALUE = -1
  Const GENERIC_READ = &H80000000
  Const FILE_SHARE_READ = 1
  Const OPEN_EXISTING = 3
  Const MEM_RESERVE = &H2000
  Const MEM_COMMIT = &H1000
  Const PAGE_READWRITE = 4
  Const MEM_RELEASE = &H8000
    
    
  On Error GoTo ErrHandler

  verifySystemVersion
  InitFctPtrStub
    
  hFile = INVALID_HANDLE_VALUE
    
  Set r = ThisWorkbook.Worksheets(1).Range("IDL_START")
     
  
  
  hFile = CreateFileW(StrPtr(FullPath), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, 0, 0)

  If hFile = INVALID_HANDLE_VALUE Then
    RaiseWinError Err.LastDllError, FullPath
  ElseIf hFile = 0 Then
    'ggf. Problem mit Makroscanner (Aufrufe wurde geblockt)
    Err.Raise vbObjectError, , "Generic failure: possibly due to restriction by macro scanner" & vbCrLf & "please contact your administrator"
  End If
  
  dwSize = GetFileSize(hFile, 0)
  If dwSize = -1 Then RaiseWinError Err.LastDllError
  
  pBuffer = VirtualAlloc(0, dwSize, MEM_RESERVE Or MEM_COMMIT, PAGE_READWRITE)
  If pBuffer = 0 Then RaiseWinError Err.LastDllError
  
  If ReadFile(hFile, pBuffer, dwSize, dwRead, 0) = 0 Then RaiseWinError Err.LastDllError
  
  Set oModule = InitIntApplication(ObjPtr(Context), r, pBuffer, dwSize)
    
Cleanup:
  If hFile <> INVALID_HANDLE_VALUE Then
    CloseHandle hFile
    hFile = INVALID_HANDLE_VALUE
  End If
  If pBuffer <> 0 Then
    VirtualFree pBuffer, 0, MEM_RELEASE
    pBuffer = 0
  End If
  If nError <> 0 Then
    On Error GoTo 0
    Err.Raise nError, , strError
  End If
  
  Set LoadDllModuleMem = oModule
  
  Exit Function
ErrHandler:
  nError = Err.Number
  strError = Err.Description
  On Error Resume Next
  
  'Fehlernummer hinzufügen
  If nError < 0 Then
    strError = strError & vbLf & "Error=" & Hex(nError)
  Else
    strError = strError & vbLf & "Error=" & nError
  End If
  
  GoTo Cleanup
  Resume
End Function




#End If 'Win64 = 0 Then


Private Sub Class_Initialize()
  Set m_app = Application
  m_nAppisolation = -1 'unbestimmt
End Sub



Private Sub Class_Terminate()
  If m_hProcessIdSpreadApp <> 0 Then
    CloseHandle m_hProcessIdSpreadApp
    m_hProcessIdSpreadApp = 0
  End If
…