Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 ef5b50960c87f8f9…

MALICIOUS

Office (OOXML)

1.91 MB Created: 2015-11-03 09:56:08 UTC Authoring application: Microsoft Excel 16.0300 First seen: 2021-07-07
MD5: 68339e013da1c4cb402184df787d330d SHA-1: cc356802da6d484f70358c1803bb236eca686225 SHA-256: ef5b50960c87f8f9252a57876484db34de057164930c694f9920c41528a52fb0
382 Risk Score

Malware Insights

MITRE ATT&CK
T1059.005 Visual Basic T1204.002 Malicious File T1059 Command and Scripting Interpreter T1566.001 Spearphishing Attachment

The sample is an Excel document containing obfuscated VBA macros with Auto_Open and Workbook_Open subroutines. These macros utilize Shell() and CreateObject() calls, indicating an attempt to execute arbitrary code. The presence of an Equation Editor OLE object and a Workbook_Open macro suggests a common pattern for malware delivery. The document body contains financial-like data, potentially serving as a lure.

Heuristics 15

  • Equation Editor OLE object high CVE related OLE_EQUATION_EDITOR
    Embedded OLE object xl/embeddings/oleObject1.bin contains the Equation Editor CLSID, the legacy component exploited by CVE-2017-11882, CVE-2018-0802, and CVE-2018-0798.
  • VBA project inside OOXML medium 8 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present
  • Shell() call in VBA critical OLE_VBA_SHELL
    Shell() call in VBA
    Matched line in script
        ' perform a a shell sort of the string array
    For X = 0 To (z - 2)
  • Obfuscated auto-exec VBA loader critical OLE_VBA_OBFUSCATED_AUTOEXEC_LOADER
    Auto-exec VBA reconstructs strings with a heavy custom decoder (numeric char-array, repeated hex-string decode, or junk-token Replace removal) and feeds them to a COM-instantiation or execution sink. This obfuscated-loader shape keeps CreateObject/Shell/URL indicators out of the macro source.
    Matched line in script
        ' perform a a shell sort of the string array
    For X = 0 To (z - 2)
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
    Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.OpenTextFile("\\10.175.15.81\DO_IP\version.txt", ForReading)
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
    Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
    ExecQuery("Select * from Win32_PingStatus Where Address = '" & Host & "'")
  • VBA p-code auto-exec with execution tokens high OLE_VBA_PCODE_AUTOEXEC_EXEC
    Compiled VBA/cache stream contains an auto-execution token together with shell/download/object-execution tokens. This catches p-code-only or source-extraction-failure macro documents where visible source is unavailable.
  • Workbook_Open macro low OLE_VBA_WBOPEN
    Workbook_Open macro
    Matched line in script
    Private Sub Workbook_Open()
    mbNeedcalculate = True
  • Auto_Open macro low OLE_VBA_AUTO
    Auto_Open macro
    Matched line in script
    Attribute VB_Name = "eOpen"
Sub Auto_Open()
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
    LogInformation (Now & ";" & Environ$("username") & ";" & Environ$("COMPUTERNAME"))
Auto_UpdateRessources
  • External relationship medium OOXML_EXTERNAL_REL
    External target in xl/drawings/_rels/drawing2.xml.rels: cid:image001.png@01D1E125.43220E80
  • Embedded OLE object medium OOXML_OLE_OBJECT
    Document contains an embedded OLE object
  • External hyperlinks (1) low OOXML_EXTERNAL_HYPERLINKS
    Document contains 1 external hyperlink — clickable URLs are stored as external relationships. First target: file:///\\10.175.15.81\do_ip
  • Hidden worksheet (hidden) low OOXML_HIDDEN_SHEET
    Excel workbook contains 1 hidden sheet(s) — hidden sheets are commonly used to conceal macro code, staging data, or intermediate payload construction
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://schemas.microsoft.com/office/2009/07/customui Document hyperlink
    • http://schemas.microsoft.com/office/2006/01/customuiDocument hyperlink

Extracted artifacts 4

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 144888 bytes
SHA-256: 2636657df0811a3b334d2745ff5f85314037dd87cf490b5c584abf2b4388629f
Preview script
First 1,000 lines of the extracted script
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


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

'On purge toutes les validations de données qui peuvent dépasser 255 caractères
Feuil2.Columns("C:D").Validation.Delete

End Sub

Private Sub Workbook_Open()
    mbNeedcalculate = True
    LockRecap
End Sub

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



Private Sub Worksheet_Activate()
    
End Sub

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Columns.Count > 1 Then Exit Sub
If Target.Rows.Count > 1 Then Exit Sub

If Target.row >= lig_deb + 1 And Target.row <= Get_LastLine And Target.Count = 1 Then

    Dim typeRessource As String
    typeRessource = UCase(Me.Cells(Target.row, col_TypeRessource).value)

    Dim CodeRessource As String
    CodeRessource = UCase(Me.Cells(Target.row, col_CodeRessource).value)

    Dim Fonction As String
    Fonction = UCase(Me.Cells(Target.row, col_Fonction).value)

    If Target.Column = col_TypeRessource Then
        
        Target.Validation.Delete
        Target.Validation.Add xlValidateList, Formula1:="Agent,Engin"
        
    ElseIf Target.Column = col_CodeRessource Then
    
        Feuil2.Columns("C:D").Validation.Delete
        Set d = SetValidationDATA_Code(typeRessource, Fonction)
        If Not d Is Nothing Then
            Dim temp As String
            temp = Join(d.Keys, ",")
        
            If d.Count > 0 Then Target.Validation.Add xlValidateList, Formula1:=temp
        Else
            If Cells(Target.row, col_Fonction).value <> "" Then Cells(Target.row, col_Fonction).value = ""
        End If
            
    ElseIf Target.Column = col_Fonction Then
    
        Feuil2.Columns("C:D").Validation.Delete
        Set d = SetValidationDATA_Fonction(typeRessource, CodeRessource)
        If Not d Is Nothing Then
            If d.Count > 0 Then Target.Validation.Add xlValidateList, Formula1:=Join(d.Keys, ",")
        End If
        
     
    End If

        Exit Sub
        
    End If


  
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

ClearRecap

If Target.Columns.Count > 1 Then Exit Sub
If Target.Rows.Count > 1 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub

Dim c As Range
For Each c In Target.Cells

    If c.row >= lig_deb + 1 And c.row <= Get_LastLine And (c.Column = col_TypeRessource Or c.Column = col_CodeRessource Or c.Column = col_Fonction Or _
     c.Column = col_DJS Or c.Column = col_NUIT Or c.Column = col_Mobilite) Then
    
        Dim typeRessource As String
        typeRessource = UCase(Me.Cells(c.row, col_TypeRessource).value)
        
        Dim CodeRessource As String
        CodeRessource = UCase(Me.Cells(c.row, col_CodeRessource).value)
        
        Dim Fonction As String
        Fonction = Me.Cells(c.row, col_Fonction).value
        
        Set d1 = SetValidationDATA_Code(typeRessource, Fonction)
        Set d2 = SetValidationDATA_Fonction(typeRessource, CodeRessource)
    
        Select Case c.Column
            Case col_TypeRessource
        
                If d1 Is Nothing Then
                    If Cells(c.row, col_CodeRessource).value <> "" Then Cells(c.row, col_CodeRessource).value = ""
                Else
                    If Not d1.Exists(CodeRessource) Then
                        If Cells(c.row, col_CodeRessource).value <> "" Then Cells(c.row, col_CodeRessource).value = ""
                    End If
                End If
                
                If d2 Is Nothing Then
                    If Cells(c.row, col_Fonction).value <> "" Then Cells(c.row, col_Fonction).value = ""
                Else
                    If Not d2.Exists(Fonction) Then
                        If Cells(c.row, col_Fonction).value <> "" Then Cells(c.row, col_Fonction).value = ""
                    End If
                End If
    
            Case col_CodeRessource
            
                If Not d2 Is Nothing Then
                    If d2.Count > 0 Then
                        
                        If d2.Count = 1 Then
                            A = d2.Keys
                            If Cells(c.row, col_Fonction).value <> A(0) Then Cells(c.row, col_Fonction).value = A(0)
                            
                        End If
                        
                        If c.value = "" Then
                           ' Cells(c.Row, col_Fonction).Value = ""
                        
                        ElseIf d2.Count > 1 Then
                        
                            If Cells(c.row, col_Fonction).value = "" Then
                                Cells(c.row, col_Fonction).Select
                                SendKeys "%{down}"
                                VérifEtatNumlock
                            ElseIf Not d2.Exists(Cells(c.row, col_Fonction).text) Then
                                If Cells(c.row, col_Fonction).value <> "" Then Cells(c.row, col_Fonction).value = ""
                              '  SendKeys "%{down}"
                            
                            End If
                            
                        End If
                        
                    
                    End If
                    
                End If
             
                
            Case col_Fonction
            
                If Not d1 Is Nothing Then
                    If d1.Count > 0 Then
                    
                        If d1.Count = 1 Then
                            A = d1.Keys
                            If Cells(c.row, col_CodeRessource).value <> A(0) Then Cells(c.row, col_CodeRessource).value = A(0)
                        
                        End If
                     
                    End If
                
                End If
                
            Case col_DJS, col_NUIT, col_Mobilite
                If c.Interior.Pattern = xlLightUp Then
                      If c.value <> "" Then
                        c.value = ""
                        rep2 = MsgBox("Ce champ est bloqué, vous n'avez pas à saisir dans cette cellule!", vbCritical, "Champ verrouillé")
                      End If
                End If

        End Select
        
        Set_Formula (c.row)
        
        
    End If
    
Next c
  
End Sub








Attribute VB_Name = "Feuil19"
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 = "Feuil10"
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 = "Feuil29"
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 = "Feuil6"
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 = "Feuil7"
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 = "mDictionary"
Public Const dictKey = 1
Public Const dictItem = 2

Public Sub SortDictionary(objDict, intSort)
  ' declare our variables
  Dim strDict()
  Dim objKey
  Dim strKey, strItem
  Dim X, Y, z

  ' get the dictionary count
  z = objDict.Count

  ' we need more than one item to warrant sorting
  If z > 1 Then
    ' create an array to store dictionary information
    ReDim strDict(z, 2)
    X = 0
    ' populate the string array
    For Each objKey In objDict
        strDict(X, dictKey) = CStr(objKey)
        strDict(X, dictItem) = CStr(objDict(objKey))
        X = X + 1
    Next

    ' perform a a shell sort of the string array
    For X = 0 To (z - 2)
      For Y = X To (z - 1)
        If StrComp(strDict(X, intSort), strDict(Y, intSort), vbTextCompare) > 0 Then
            strKey = strDict(X, dictKey)
            strItem = strDict(X, dictItem)
            strDict(X, dictKey) = strDict(Y, dictKey)
            strDict(X, dictItem) = strDict(Y, dictItem)
            strDict(Y, dictKey) = strKey
            strDict(Y, dictItem) = strItem
        End If
      Next
    Next

    ' erase the contents of the dictionary object
    objDict.RemoveAll

    ' repopulate the dictionary with the sorted information
    For X = 0 To (z - 1)
      objDict.Add strDict(X, dictKey), strDict(X, dictItem)
    Next

  End If

End Sub


Public Function ConvertDataWithoutComma(ByVal text As String)

'on remplace la virgule par un caractère approchant (ALT+0130)
ConvertDataWithoutComma = Trim(Replace(text, ",", ";"))

End Function

Public Function ConvertDataWithComma(ByVal text As String)

'on remplace le caractère approchant (ALT+0130) par la vraie virgule
ConvertDataWithComma = Replace(text, ";", ",")

End Function





Attribute VB_Name = "Feuil22"
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 = "variables"
Public mPhaseopt As Integer

Public mStatutOpt As Integer


Public Function col_chantier() As Integer
    col_chantier = Feuil2.Range("col_chantier").Column
End Function

Public Function col_TypeRessource() As Integer
    col_TypeRessource = Feuil2.Range("col_TypeRessource").Column
End Function

Public Function col_CodeRessource() As Integer
    col_CodeRessource = Feuil2.Range("col_CodeRessource").Column
End Function

Public Function col_Fonction() As Integer
    col_Fonction = Feuil2.Range("col_Fonction").Column
End Function

Public Function col_pMOET() As Integer
    col_pMOET = Feuil2.Range("col_pMOET").Column
End Function

Public Function col_DJS() As Integer
    col_DJS = Feuil2.Range("col_DJS").Column
End Function

Public Function col_NUIT() As Integer
    col_NUIT = Feuil2.Range("col_NUIT").Column
End Function

Public Function col_Mobilite() As Integer
    col_Mobilite = Feuil2.Range("col_Mobilite").Column
End Function

Public Function col_remarque() As Integer
    col_remarque = Feuil2.Range("col_remarque").Column
End Function

Public Function col_Externalisable() As Integer
    col_Externalisable = Feuil2.Range("col_Externalisable").Column
End Function

Public Function col_NBJSem() As Integer
    col_NBJSem = Feuil2.Range("col_NBJSem").Column
End Function

Public Function col_NBJWEF() As Integer
    col_NBJWEF = Feuil2.Range("col_NBJWEF").Column
End Function

Public Function col_NBTot() As Integer
    col_NBTot = Feuil2.Range("col_NBTot").Column
End Function

Public Function col_FirstDate() As Integer
    col_FirstDate = Feuil2.Range("date_debut").Column
End Function

Public Function lig_deb() As Integer
    lig_deb = Feuil2.Range("col_chantier").row + 1
End Function

'=====================================================================
Public Function ligDev_deb() As Integer
    ligDev_deb = Range("colDev_Description").row + 1
End Function

Public Function ligDev_Fin() As Integer
    ligDev_Fin = Range("ligDev_Fin").row - 1
End Function

Public Function ligAchatExterne_Fin() As Integer
    ligAchatExterne_Fin = Range("ligne_Fin_AchatExterne").row - 1
End Function

Public Function colDev_Description() As Integer
    colDev_Description = Range("colDev_Description").Column
End Function

Public Function colDev_pMOET() As Integer
    colDev_pMOET = Range("colDev_pMOET").Column
End Function

Public Function colDev_Montant() As Integer
    colDev_Montant = Range("colDev_Montant").Column
End Function



Attribute VB_Name = "mRibbon"
Private Const VersionDO As Integer = 44


' --- DECLARATION API WINDOWS
#If VBA7 Then
  Declare PtrSafe Function ShellExecute _
    Lib "shell32.dll" _
    Alias "ShellExecuteA" ( _
      ByVal hwnd As LongPtr, ByVal lpOperation As String, _
      ByVal lpFile As String, ByVal lpParameters As String, _
      ByVal lpDirectory As String, ByVal nShowCmd As Long) _
    As LongPtr
#Else
  Declare Function ShellExecute _
    Lib "shell32.dll" _
    Alias "ShellExecuteA" ( _
      ByVal hwnd As Long, ByVal lpOperation As String, _
      ByVal lpFile As String, ByVal lpParameters As String, _
      ByVal lpDirectory As String, ByVal nShowCmd As Long) _
    As Long
#End If

Public Const SW_SHOWNORMAL = 1

Public oRibbon As IRibbonUI
Sub RibbonOnLoad(ribbon As IRibbonUI)
    Set oRibbon = ribbon
    
    On Error Resume Next
    If val(Application.Version) = 14 Then
        oRibbon.ActivateTab "DO" ' For Excel 2010
    ElseIf val(Application.Version) = 12 Then
        Application.OnTime Now() + TimeValue("00:00:01"), "ActivateRibbon" 'For Excel 2007
    End If
        
End Sub

Public Function VerDO() As Integer

    VerDO = VersionDO

End Function


Sub ActivateRibbon()

Application.SendKeys "%Y{F6}"

End Sub

Public Sub Historique(control As IRibbonControl)

Select Case Ping("10.175.15.81")
    Case 1
        'MsgBox "Connection réussie !"
        
    Case Else
        
        rep = MsgBox("Impossible de se connecter au serveur." & Chr(10) & _
        "Vérifier votre connexion réseau !", vbCritical, "Erreur de connexion au serveur")

        Exit Sub

End Select


RUNShellExecute ("\\10.175.15.81\do_ip\docs\HistoriqueDO.pdf")
  
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Import_DATA
' Author    : Michael Rafesthain
' Date      : 24/03/2016
' Purpose   :  Délégué de l'event click du bouton import
'              Lance le processus d'importation d'un fichier exp.
'---------------------------------------------------------------------------------------
' Parameters :
' control                   : Control du Ribbon ayant appelé la méthode
'---------------------------------------------------------------------------------------
Public Sub Import_DATA(control As IRibbonControl)

On Error GoTo Err_Imp

    ChDir ThisWorkbook.Path

    Dim exp As New clsExportImport
    
    exp.Initialise
    
    Dim wsDevisInterne As Worksheet
    
    If exp.ReadFromFileWithProgress(Feuil2, Feuil12, Feuil12, Feuil4) Then
        
    End If
    
    Set exp = Nothing
    
    Exit Sub


Err_Imp:
    MsgBox Err.Description, vbCritical, "Erreur"
End Sub

'---------------------------------------------------------------------------------------
' Procedure : Import_DATA
' Author    : Michael Rafesthain
' Date      : 24/03/2016
' Purpose   :  Délégué de l'event click du bouton export
'
'---------------------------------------------------------------------------------------
' Parameters :
' control                   : Control du Ribbon ayant appelé la méthode
' Remarks    : Si la feuille saisie du classeur ne contient aucune donnée alors on demande
'              une boite de dialogue demande le fichier que l'on veut traiter.
'
'---------------------------------------------------------------------------------------
Public Sub Export_DATA(control As IRibbonControl)
On Error GoTo Err_Exp

    ChDir ThisWorkbook.Path

    Dim lastRow As Integer
    Dim colTot As Integer
    Dim Index As Integer
    Dim HasValue As Boolean
    Dim exp As New clsExportImport
    Dim DefaultFileName As String
    
    lastRow = Get_LastLine
    colTot = col_NBTot
    On Error Resume Next
    HasValue = False
    For Index = lig_deb To lastRow
        If IsNumeric(Feuil2.Cells(Index, colTot).value) And Feuil2.Cells(Index, colTot).value > 0 Then
            HasValue = True
            Exit For
        End If
    Next Index
    
    On Error GoTo 0


    If HasValue Then
        DefaultFileName = Strings.Replace(ThisWorkbook.Name, ".xlsm", "")
        Set exp = New clsExportImport
        
        exp.Initialise
        
        exp.WriteToFile Feuil2, Feuil12, Feuil12, Feuil4, VersionDO, DefaultFileName
        
        Set exp = Nothing
    Else
        Dim strFichier As String
        
        strFichier = Application.GetOpenFilename("Fichier DO, *.xls; *.xlsx; *.xlsm", , "Fichier DO à exporter", , False)
        If strFichier <> "Faux" And strFichier <> "False" Then
        
            Dim oBook As Workbook
            Dim iVersion As Integer
            
            Application.ScreenUpdating = False
            
            Set oBook = Application.Workbooks.Open(strFichier)
            DefaultFileName = Strings.Replace(oBook.Name, ".xlsm", "")
            
            iVersion = EstimVersion(oBook)
            
            If iVersion = 0 Then
                MsgBox "Le fichier n'est pas dans une version compatible avec le processus d'export de donnée!" + vbCrLf + "Seuls les fichiers issuent de la version 36 et ultérieure, sont pris en charge", vbExclamation, "Information"
                oBook.Close False
                Set oBook = Nothing
            Else
            
                Select Case iVersion
                    Case 36
                        Set exp = New clsExportImport
            
                        exp.Initialise
                        
                        exp.WriteToFile oBook.Worksheets("Saisie"), Nothing, oBook.Worksheets("Devis Achats"), oBook.Worksheets("page de garde"), iVersion, DefaultFileName
                        
                        Set exp = Nothing
                        
                    Case Else
                    
                        Set exp = New clsExportImport
                
                        exp.Initialise
                    
                        exp.WriteToFile oBook.Worksheets("Saisie"), oBook.Worksheets("AchatsExterne"), oBook.Worksheets("DevisInterne"), oBook.Worksheets("page de garde"), iVersion, DefaultFileName
                    
                        Set exp = Nothing
                End Select
                
                oBook.Close False
                Set oBook = Nothing
                
            End If
        
            Application.ScreenUpdating = True
        End If
        
    End If
    
    Exit Sub
Err_Exp:
    MsgBox Err.Description, vbCritical, "Erreur"
    
End Sub


Sub Contact(control As IRibbonControl)

Dim URL As String
URL = "mailto: michel.delpuech@reseau.sncf.fr;olivier.munoz@reseau.sncf.fr;raymond.brun@reseau.sncf.fr?Subject=DO IP : Retour utilisateur&cc=benoit.lavabre@reseau.sncf.fr;alain.delaunay@reseau.sncf.fr;francois.banzet@reseau.sncf.fr&body=Détaillez ici vos questions / suggestions d'amélioration"
RUNShellExecute (URL)

End Sub

Sub MAJ(control As IRibbonControl)

Select Case Ping("10.175.15.81")
    Case 1
        'MsgBox "Connection réussie !"
        
    Case Else
        
        rep = MsgBox("Impossible de se connecter au serveur." & Chr(10) & _
        "Vérifier votre connexion réseau !", vbCritical, "Erreur de connexion au serveur")

        Exit Sub

End Select

If VerDO >= VersionDO_Serveur Then
    rep = MsgBox("Vous disposez déjà de la dernière version du fichier DO I&P" & Chr(10) & _
    "Souhaitez-vous ouvrir une fenêtre pour que vous puissiez récupérer la dernière version du fichier?", vbYesNo, "Version à jour!")
            
    If rep = vbYes Then
        RUNShellExecute ("\\10.175.15.81\DO_IP")
    End If
    
Else
    MsgBox "Une nouvelle version est disponible ! Une fenêtre va s'ouvrir pour que vous puissiez récupérer la dernière version du fichier", vbExclamation, "Version périmée!"
    RUNShellExecute ("\\10.175.15.81\DO_IP")

End If

End Sub

Sub MAJ_WithoutRibbon()

Select Case Ping("10.175.15.81")
    Case 1
        If VerDO < VersionDO_Serveur Then
            rep = MsgBox("Une nouvelle version du DO LEA est disponible !" & Chr(10) & Chr(10) & _
            "Si vous avez commencé à travailler sur ce fichier, vous pouvez utiliser la fonction d'EXPORT." & Chr(10) & _
            "Vous pouvez ensuite IMPORTER vos données dans la dernière version du DO." & Chr(10) & Chr(10) & _
            "Souhaitez-vous ouvrir une fenêtre pour que vous puissiez récupérer la dernière version du fichier?", vbYesNo, "Version périmée!")
            
            If rep = vbYes Then
                RUNShellExecute ("\\10.175.15.81\DO_IP")
            End If
    
            Exit Sub
            
        End If
        
    Case Else
        'ne rien faire car connexion réseau indisponible
              
End Select

End Sub

Sub RUNShellExecute(ByVal URL)

Call ShellExecute(hwnd, "Open", URL, 0&, 0&, SW_SHOWNORMAL)

End Sub

Function VersionDO_Serveur() As Integer
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim fso, MyFile

Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.OpenTextFile("\\10.175.15.81\DO_IP\version.txt", ForReading)

VersionDO_Serveur = MyFile.ReadLine
MyFile.Close

End Function

'---------------------------------------------------------------------------------------
' Procedure : EstimVersion
' Author    : Michael Rafesthain
' Date      : 24/03/2016
' Purpose   : Estime la version d'un classeur DO (ne sont pris en charge
'             que les classeurs de version 36 et ultérieur)
'
'---------------------------------------------------------------------------------------
' Parameters :
' oBook                   : Classeur dont on estime la version
'---------------------------------------------------------------------------------------
' Remarks    : Avant la version 39, le numéro de version n'est pas disponible dans le
'              classeur.
'             Version 36 :
'                          - la feuille "page de garde" doit être présente
'                          - la feuille "Saisie" doit être présente
'                          - la feuille "Devis Achats" doit être présente
'                          - le range nommé "nom_projet" doit être présent
'                          - le range nommé "surc_corp" ne doit pas être présent
'             Version 37 ou 38 :
'                          - la feuille "page de garde" doit être présente
'                          - la feuille "Saisie" doit être présente
'                          - la feuille "DevisInterne" doit être présente
'                          - la feuille "AchatsExterne" doit être présente
'                          - le range nommé "NumVersion" ne doit pas être présent
'             Version 39 :
'                          - la feuille "page de garde" doit être présente
'                          - la feuille "Saisie" doit être présente
'                          - la feuille "DevisInterne" doit être présente
'                          - la feuille "AchatsExterne" doit être présente
'                          - le range nommé "NumVersion" DOIT être présent
'
'---------------------------------------------------------------------------------------
Private Function EstimVersion(oBook As Workbook)
    On Error Resume Next
    
    EstimVersion = 0
    
    Dim oSheet As Worksheet
    Dim Rg As Range
    
    Set oSheet = oBook.Worksheets("page de garde")
    If Err <> 0 Then
        Exit Function
    End If
    
    Set oSheet = oBook.Worksheets("Saisie")
    If Err <> 0 Then
      EstimVersion = 0
      Exit Function
    End If
    
    ' Fichier 36
    Set oSheet = oBook.Worksheets("Devis Achats")
    If Err = 0 Then
        EstimVersion = 36
            
        Set Rg = oBook.Names("nom_projet").RefersToRange
        If Err = 0 Then
            Set Rg = oBook.Names("surc_corp").RefersToRange
            If Err <> 0 Then
                Exit Function
            Else
                EstimVersion = 0
                Exit Function
            End If
        Else
            EstimVersion = 0
            Exit Function
        End If
                
    End If
    
    Err.Clear
    EstimVersion = 38
    

    Set oSheet = oBook.Worksheets("DevisInterne")
    If Err <> 0 Then
      EstimVersion = 0
      Exit Function
    End If

    Set oSheet = oBook.Worksheets("AchatsExterne")
    If Err <> 0 Then
      EstimVersion = 0
      Exit Function
    End If

    Set Rg = oBook.Names("NumVersion").RefersToRange
    If Err = 0 Then
        Dim str As String
        str = Rg.text
        If IsNumeric(Strings.Replace(str, "DO ", "")) Then
            EstimVersion = CInt(Strings.Replace(str, "DO ", ""))
        Else
            EstimVersion = 0
            Exit Function
        End If
    End If
    
    EstimVersion = 38
End Function




Attribute VB_Name = "Feuil28"
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 = "Feuil14"
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 = "Feuil12"
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 = "eOpen"
Sub Auto_Open()

LogInformation (Now & ";" & Environ$("username") & ";" & Environ$("COMPUTERNAME"))
Auto_UpdateRessources
MAJ_WithoutRibbon

End Sub

Sub Auto_UpdateRessources()

Dim URL_DATA As String
URL_DATA = "\\10.175.15.81\do_ip\DATA\data3.xlsx"

Dim Onglets As Variant
Onglets = Array("CoutsUnitaires", "Ressources_AGENT", "Ressources_ENGIN", "Platine")

Dim Variables As Variant
Dim DateMaj As Date

'On vérifie qu'une connexion réseau au serveur est disponible sinon on quitte la routine
Select Case Ping("10.175.15.81")
    Case 1
        'MsgBox "Connection réussie !"
    Case Else
        Exit Sub
End Select

'On vérifie que le fichier data.xlsx est disponible sinon on quitte la routine
If Dir(URL_DATA) = "" Then
    Exit Sub
End If

'On vérifie que les onglets "CoutsUnitaires", "Ressources_AGENT", "Ressources_ENGIN" sont bien présents sinon on quitte la routine
If ContainsAllSheets(Onglets) = False Then
    Call MsgBox("Vous avez renommé les onglets 'CoutsUnitaires', 'Ressources_AGENT', 'Ressources_ENGIN' ou 'Platine'. De fait, il n'est plus possible de mettre à jour automatiquement ces données", vbCritical, "Détection de fichier bidouillé")
    Exit Sub
End If

'On vérifie qu'une MAJ est nécessaire sinon on quitte la routine
DateMaj = FileDateTime(URL_DATA)
If DateMaj = ThisWorkbook.Worksheets(Onglets(0)).Range("A2").value Then
    Exit Sub
End If

'On demande à l'utilisateur s'il souhaite importer les nouvelles ressources
rep = MsgBox("Une mise à jour des données 'Ressources Agent-Engin'/'Platine'/'CoutsUnitaire' est disponible." & Chr(10) & _
             "Souhaitez-vous mettre à jour automatiquement votre fichier avec ces nouvelles données?", vbYesNo, "Mise à jour automatique")
If rep = vbNo Then
    Exit Sub
End If

'Initialisation
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Ouverture du fichier modèle
Dim wb_data As Workbook
Set wb_data = Workbooks.Open(URL_DATA, False, True)
Variables = Get_Names(wb_data)

'Suppression des onglets périmés
DeleteSheets (Onglets)

'Suppression des variables locales du classeur
DeleteNames (Variables)

'Import des données les plus récentes
wb_data.Sheets(Onglets).Copy After:=Feuil14 'BD_Ressources
ThisWorkbook.ChangeLink Name:=URL_DATA, NewName:=ThisWorkbook.Name, Type:=xlExcelLinks
ThisWorkbook.Sheets(Onglets(0)).Range("A2").value = DateMaj
For Each ws In Onglets
    ThisWorkbook.Sheets(ws).Protect "DOIG"
Next

'Fermeture du fichier modèle
wb_data.Close

'Finalisation
refresh_BD_RessourcesWithoutRibbon
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Vos données d'entrées (Ressources Agent / Engin, Couts Unitaires) viennent d'être mise à jour" & Chr(10) _
     & "Date version = " & DateMaj, vbOKOnly, "Mise à jour automatique"

End Sub


Function Get_Names(wb As Workbook) As Variant

temp = ""

For Each nom In wb.Names
    
    If Left(nom.Name, 5) = "Sheet" Then
        X = Split(nom.Name, "!")
        etendue = X(0)
        vScope = "WorkSheet"
        rnom = X(1)
    Else
        etendue = "Workbook"
        vScope = etendue
        rnom = nom.Name
    End If
    
    If etendue = "Workbook" Then
        If InStr(rnom, "!") = 0 Then
            temp = temp & "|" & rnom
        End If
    End If
    
Next

Get_Names = Split(Right(temp, Len(temp) - 1), "|")

End Function

Sub DeleteNames(ByVal Variables As Variant)
On Error Resume Next
For Each v In Variables
    ThisWorkbook.Names(v).Delete
Next
End Sub

Sub DeleteSheets(ByVal Onglets As Variant)
On Error Resume Next
For Each ws In Onglets
    ThisWorkbook.Sheets(ws).Delete
Next
…
ooxml_oleobject_00.bin ooxml-ole-object OOXML embedded OLE part: xl/embeddings/oleObject1.bin 3072 bytes
SHA-256: 4873753529532777640f62c22e16d83709b256db4d9e4c40340b337d49832927
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 658432 bytes
SHA-256: 84a1ebfb5717bcb0e378dba2219e3adb8bd2a40999039e3625857b5879e98b41
emf_00.emf ooxml-emf OOXML EMF part: xl/media/image1.emf 7004 bytes
SHA-256: 5fb7e216c85513f35e5047be21dbf5af265c94c95c902b0bda08e06867b20129

Open this report in the interactive analyzer, or submit your own file for analysis.