Malicious Office (OOXML) / .XLSX — 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
Private Sub Workbook_Open()
    
    StandardStart
        
    SaveFirstOpenDate

End Sub

Attribute VB_Name = "EmailFunction"
Sub Send_Email_With_Selected_Tabs()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim TempWB As Workbook
    Dim TempFilePath As String
    Dim SheetNames As Variant
    Dim ws As Worksheet
    Dim EmailList As String
    Dim c As Range
    Dim UnitName As String
    Dim i As Long
    Dim vbComp As Object

    '--------------------------------------------------
    'REFRESH SHAREPOINT LIST
    '--------------------------------------------------
    Application.ScreenUpdating = False
    Application.EnableEvents = False

    ThisWorkbook.RefreshAll
    Application.CalculateUntilAsyncQueriesDone

    '--------------------------------------------------
    'SETUP DATA
    '--------------------------------------------------
    SheetNames = Array("Unit Summary", "DO Demand", "DO Supply", "Confirmation")
    UnitName = Trim(ThisWorkbook.Worksheets("Unit Summary").Range("C3").Value)

    'Build email list from RSG!A16:D16
    EmailList = ""
    For Each c In ThisWorkbook.Worksheets("RSG").Range("A16:E16")
        If Trim(c.Value) <> "" Then EmailList = EmailList & c.Value & ";"
    Next c

    If Right(EmailList, 1) = ";" Then
        EmailList = Left(EmailList, Len(EmailList) - 1)
    End If

    '--------------------------------------------------
    'CREATE TEMP WORKBOOK
    '--------------------------------------------------
    Set TempWB = Workbooks.Add

    'Copy required sheets
    For Each ws In ThisWorkbook.Worksheets
        If Not IsError(Application.Match(ws.name, SheetNames, 0)) Then
            ws.Copy After:=TempWB.Sheets(TempWB.Sheets.Count)
        End If
    Next ws

    'Remove default sheets safely
    Application.DisplayAlerts = False
    For i = TempWB.Worksheets.Count To 1 Step -1
        If IsError(Application.Match(TempWB.Worksheets(i).name, SheetNames, 0)) _
           And TempWB.Worksheets.Count > 1 Then
            TempWB.Worksheets(i).Delete
        End If
    Next i
    Application.DisplayAlerts = True

    '--------------------------------------------------
    'REMOVE ALL VBA CODE FROM TEMP WORKBOOK
    'requires low security on Macros - saving as xlsx
    ' with displayalerts = false should remove modules
    '--------------------------------------------------
 On Error Resume Next
    For Each vbComp In TempWB.VBProject.VBComponents
        If vbComp.Type <> 100 Then  'Keep only document objects briefly
            TempWB.VBProject.VBComponents.Remove vbComp
        End If
    Next vbComp

    'Also clear any remaining sheet code
    For Each vbComp In TempWB.VBProject.VBComponents
        vbComp.CodeModule.DeleteLines 1, vbComp.CodeModule.CountOfLines
    Next vbComp
On Error GoTo 0
    '--------------------------------------------------
    'SAVE AS XLSX (NOW SAFE)
    '--------------------------------------------------
    Application.DisplayAlerts = False
    TempFilePath = Environ$("TEMP") & "\DO_Report_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
    TempWB.SaveAs TempFilePath, xlOpenXMLWorkbook
    TempWB.Close False

    '--------------------------------------------------
    'EMAIL
    '--------------------------------------------------
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = EmailList
        .cc = GetUserEmail
        .bcc = "USO.Assurance"
        .Subject = UnitName & " - Rapid Base Data - Disagreement - " & GetRODName
        .Body = "Hello," & vbCrLf & vbCrLf & _
                "Please find attached the Rapid Base Data Disagreement file." & vbCrLf & vbCrLf & _
                "Regards,"
        .Attachments.Add TempFilePath
        .Send   'Change to .Send if required
    End With

Cleanup:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

End Sub


Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    ' Check if the changed cell is C3
    If Not Intersect(Target, Me.Range("C3")) Is Nothing Then
        Sheets("SPUpload").Range("C3").Value = ""
        Sheets("SPUPload").Range("A1:B1").Value = ""
        SaveFirstOpenDate
        If Not Me.Range("C3").Value = "" Then
            ' Prevent re-triggering if the macro modifies cells
            Application.EnableEvents = False
            
                If ThisWorkbook.Worksheets.Count > 7 Then RefreshUnitData
            
            Application.EnableEvents = True
        End If
    End If

End Sub

Attribute VB_Name = "UploadFunction"
Option Explicit

'==============================
' CONFIGURATION
'==============================
Const TEMP_PATH As String = "C:\Temp\"
Const SITE_URL As String = "https://intranet.royalmailgroup.com/sites/A3764/RBD"
Const LIST_NAME As String = "RapidBaseDataTracking"
Const UPLOAD_FOLDER As String = "https://intranet.royalmailgroup.com/sites/A3764/RBD/Rapid Base Data Tracking/"

Dim wb1, wb2 As Workbook
Dim us1, us2, dd1, dd2, ds1, ds2, c1, c2, spu1, spu2, ws As Worksheet
Dim ar1, v, links As Variant
Dim i As Long

'=========================
'Record first opened date
'=========================
Sub SaveFirstOpenDate()

    On Error Resume Next
    Dim nm As name
    Set nm = ThisWorkbook.Names("RBD_FirstOpenDate")
    On Error GoTo 0

    If nm Is Nothing Then Exit Sub

    If nm.RefersToRange.Value = "" Then
        nm.RefersToRange.Value = Date
        Sheets("SPUpload").Range("C3").Value = Environ$("USERNAME")
    End If

End Sub

'================
'Save Signatures
'================

Sub ConvertSig()

    Dim wsConfirm As Worksheet
    Dim wsUpload As Worksheet
    Dim shp As Shape
    Dim pic As Shape
    'Dim targetCell As Range
    Dim addr As String
    Dim targetCell As Range
    
    Set wsConfirm = ThisWorkbook.Worksheets("Confirmation")
    Set wsUpload = ThisWorkbook.Worksheets("SPUpload")

    'Application.ScreenUpdating = False
    ActiveWorkbook.Unprotect Password:="Mar$"
    wsUpload.Unprotect Password:="Mar$"
    wsUpload.Visible = True
    
    For Each shp In wsConfirm.Shapes

        If (shp.TopLeftCell.Address(False, False) = "B20" Or shp.TopLeftCell.Address(False, False) = "B25") Then
                  
            addr = Replace(shp.TopLeftCell.Address(False, False), ":", "") ' handles merged cells
            
            Select Case addr
                Case "B20"
                    Set targetCell = wsUpload.Range("K3")
            
                Case "B25"
                    Set targetCell = wsUpload.Range("M3")
            
                Case Else
                    Set targetCell = Nothing
            End Select
            
            If targetCell Is Nothing Then
                MsgBox "No Signature found at " & shp.TopLeftCell.Address
            Else
                'MsgBox "Pasting to " & targetCell.Address
                
                wsUpload.Activate
                
                ' Copy ink
                shp.Copy

                ' Paste as picture onto SPUpload
                wsUpload.Paste Destination:=targetCell
                Set pic = wsUpload.Shapes(wsUpload.Shapes.Count)
                Application.CutCopyMode = False
                
            End If
            
        End If
        
    Next shp
'    wsUpload.Protect Password:=SheetPWD, AllowSorting:=True, AllowFiltering:=True, UserInterfaceOnly:=True, DrawingObjects:=False
    wsUpload.Visible = xlSheetVeryHidden
'    ActiveWorkbook.Protect Password:="Mar$", Structure:=True
    Application.ScreenUpdating = True

End Sub

'=====================
'FILE UPLOAD
'=====================

Sub SP_UPLOAD(sIssue As String)
    
    Application.ScreenUpdating = False
    Dim uname As String
    
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ExtractWalkData
    UploadCopytoNAS sIssue
    
    Sheets("SPUpload").Visible = xlSheetVisible
    Set wb1 = ActiveWorkbook
    Set us1 = wb1.Worksheets("Unit Summary")
    Set dd1 = wb1.Worksheets("DO Demand")
    Set ds1 = wb1.Worksheets("DO Supply")
    Set c1 = wb1.Worksheets("Confirmation")
    Set spu1 = wb1.Worksheets("SPUpload")
    
    uname = us1.Range("C3").Value
    
    dd1.Copy
    Set wb2 = ActiveWorkbook
    Set dd2 = ActiveSheet
    
    ds1.Copy After:=dd2
    Set ds2 = ActiveSheet
    
    c1.Copy After:=ds2
    Set c2 = ActiveSheet
    
    spu1.Copy After:=c2
    
    
    Set spu2 = ActiveSheet
    
    c2.Activate
    
    If Not IsEmpty(links) Then
        For i = LBound(links) To UBound(links)
            ThisWorkbook.BreakLink _
                name:=links(i), _
                Type:=xlLinkTypeExcelLinks
        Next i
    End If
    
    With c2
        On Error Resume Next
        .Shapes("NoIssueSubmission").Delete
        .Shapes("IssueSubmission").Delete
        On Error GoTo 0
    End With
    
    ar1 = Array(dd2, ds2, c2, spu2)
    
    For Each v In ar1
        Set ws = v
        With ws
            .Unprotect Password:="Mar$"
            .UsedRange.Value = .UsedRange.Value
        'If Not v = spu2 Then _
            .Protect Password:=SheetPWD, AllowSorting:=True, AllowFiltering:=True, UserInterfaceOnly:=True, DrawingObjects:=False

        End With
    Next v
    
    wb2.SaveAs Filename:=UPLOAD_FOLDER & "RBD_" & uname ' & ".xlsm"  ', FileFormat:=xlOpenXMLWorkbook
    wb2.Close False
    
    spu1.Range("K3").ClearContents
    spu1.Range("M3").ClearContents
    Sheets("SPUpload").Visible = xlSheetVeryHidden
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    
End Sub

Sub NoIssueConfirmation()

    If Sheets("Confirmation").Range("K17").Value = 0 And ConfirmSignatures = True Then
        ThisWorkbook.Unprotect Password:="Mar$"
        Sheets("SPUpload").Visible = xlSheetVisible
        Range("RBD_SubmissionType").Value = "Locally Agreed"
        Range("RBD_SubmissionDate").Value = Now
        Sheets("SPUpload").Range("I3").Value = "COM & CWU Rep confirmed the accuracy of the current base data in this file"
        Sheets("SPUpload").Range("O3").Value = "No"
        SP_UPLOAD "No Issues"
        MsgBox "Rapid Base Data has been uploaded, all aspects agreed.", vbInformation
    Else
        MsgBox "Please review DO Demand and DO Supply, submission cannot continue until all relevant information is completed."
    End If
    Sheets("SPUpload").Visible = xlVeryHidden
'    ThisWorkbook.Protect Password:="Mar$", Structure:=True
    
End Sub

Sub IssueConfirmation()

    If Sheets("Confirmation").Range("K17").Value = 0 And ConfirmSignatures = True Then
        Sheets("SPUpload").Visible = xlSheetVisible
        Range("RBD_SubmissionType").Value = "Not Locally Agreed"
        Range("RBD_SubmissionDate").Value = Now
        Sheets("SPUpload").Range("I3").Value = "COM & CWU Rep are unable to agree on the accuracy of the current base data in this file and can provide evidence to support a review at a Regional Steering Group"
        Sheets("SPUpload").Range("O3").Value = "Yes"
        Send_Email_With_Selected_Tabs
        SP_UPLOAD "With Issues"
        MsgBox "Rapid Base Data has been uploaded, with Disagreement Noted and escalation has been sent.", vbInformation
    Else
        MsgBox "Please review DO Demand and DO Supply, submission cannot continue until all relevant information is completed."
    End If
        Sheets("SPUpload").Visible = xlVeryHidden
'        ThisWorkbook.Protect Password:="Mar$", Structure:=True
End Sub


Private Sub CopySheetToFile(srcSheet As Worksheet, fullPath As String)

    Dim wb As Workbook

    Set wb = Workbooks.Add(xlWBATWorksheet)

    srcSheet.UsedRange.Copy
    wb.Worksheets(1).Range("A1").PasteSpecial xlPasteAll
    Application.CutCopyMode = False

    wb.SaveAs fullPath, xlOpenXMLWorkbook
    wb.Close False

End Sub


Sub EmbedSheetsAsSeparateFiles()

    Dim wsUpload As Worksheet
    Dim wsDemand As Worksheet, wsSupply As Worksheet
    Dim tmpPath As String
    Dim fDemand As String, fSupply As String
    Dim OLEObj As OLEObject
    
    wb2.Activate
    
    Set wsUpload = wb2.Worksheets("SPUpload")
    Set wsDemand = wb2.Worksheets("DO Demand")
    Set wsSupply = wb2.Worksheets("DO Supply")

    tmpPath = Environ$("TEMP") & "\"
    fDemand = tmpPath & "DO_Demand_Temp.xlsx"
    fSupply = tmpPath & "DO_Supply_Temp.xlsx"

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    ' ----- CREATE TEMP FILES -----
    CopySheetToFile wsDemand, fDemand
    CopySheetToFile wsSupply, fSupply

    ' ----- CLEAR EXISTING OBJECTS -----
    DeleteOLEAtCell wsUpload.Range("F3")
    DeleteOLEAtCell wsUpload.Range("G3")

    ' ----- EMBED DEMAND -----
    Set OLEObj = wsUpload.OLEObjects.Add( _
        Filename:=fDemand, _
        link:=False, _
        DisplayAsIcon:=False)

    FitOLEToCell OLEObj, wsUpload.Range("F3")

    ' ----- EMBED SUPPLY -----
    Set OLEObj = wsUpload.OLEObjects.Add( _
        Filename:=fSupply, _
        link:=False, _
        DisplayAsIcon:=False)

    FitOLEToCell OLEObj, wsUpload.Range("G3")

    
    ' ----- CLEAN UP TEMP FILES -----

    SafeKill fDemand
    SafeKill fSupply

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Sub SafeKill(filePath As String)

    Dim i As Long

    For i = 1 To 10   ' ~5 seconds total
        DoEvents
        Application.Wait Now + TimeValue("0:00:05")

        On Error Resume Next
        Kill filePath
        If err.Number = 0 Then
            Exit Sub
        End If
        err.Clear
        On Error GoTo 0
    Next i

    ' Final outcome
    Debug.Print "Could not delete temp file (still locked): " & filePath

End Sub


Private Sub FitOLEToCell(OLEObj As OLEObject, targetCell As Range)

    With OLEObj
        .Left = targetCell.Left
        .Top = targetCell.Top
        .Width = targetCell.Width
        .Height = targetCell.Height
        .Placement = xlMoveAndSize
        .Locked = True
    End With

End Sub



Private Sub DeleteOLEAtCell(targetCell As Range)

    Dim ole As OLEObject

    For Each ole In targetCell.Worksheet.OLEObjects
        If ole.TopLeftCell.Address = targetCell.Address Then
            ole.Delete
        End If
    Next ole

End Sub

Attribute VB_Name = "Sheet3"
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 = "t_Sheet2"
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 = "UnitFiles"


Option Explicit

Function ProcessUnits()

Dim sLeadCOMEmailAddress As String
Dim sUnitName As String
Dim sNASFile As String, sFileName As String
Dim wbSource As Workbook
Dim iRowNo As Integer

Dim sMessage As String
sMessage = ""

Dim dNextVersion As Double
    'dNextVersion = MasterVersion
    dNextVersion = InputBox("Please Confirm Version no of Unit Files for AutoUpdates" & vbLf _
                & "N.B.  This master has a different versionnumber than the unit files, if in doubt check with Dave", "Version Number", MasterVersion)

Dim sSheetname As String
    sSheetname = InputBox("Which sheet do you wish to process files from (W2am, W2pm, W3am or W4am)", "Session Tab", "London")

UnlockSht
    For iRowNo = 2 To 60
'    For iRowNo = 2 To 18
'    For iRowNo = 7 To 7

        ClearUnitEntries
        Macro_Start_Settings
    
        'pick up unit details
        With ThisWorkbook.Sheets(sSheetname)
            sUnitName = .Range("D" & iRowNo).Value
            sLeadCOMEmailAddress = .Range("E" & iRowNo).Value
        End With
        
        'if row is not blank then process and send
        If Not sUnitName = "" Then
            'set unit in this file
            With ThisWorkbook.Sheets("Unit Summary")
                .Range("B1").Value = sLeadCOMEmailAddress
                .Range("C3").Value = Trim(sUnitName)
                Call RefreshUnitData
                Application.Calculate
            End With
            
            'create unit file seperate to this one
            sFileName = sUnitName & " RBD.xlsb"
            ThisWorkbook.SaveCopyAs sLocalPath & sFileName
                    
            'open unit file and remove background data
            Application.EnableEvents = False
            Application.DisplayAlerts = False
            Set wbSource = Workbooks.Open(sLocalPath & sFileName)
                RemoveBackgroundLinks wbSource
                DeleteBackgroundSheets wbSource
                RestoreFormulae wbSource
                LockWorkbook wbSource
                  
                SetFileAsNewVersion (dNextVersion)
                
                Macro_End_Settings
            wbSource.Close True
            
            sNASFile = sMarsPath & "AuditTrail\RBDFiles\Sent2Unit\" & "RBD" & "-" & sUnitName & "_" & Format(Now(), "yyyymmddhhmm") & ".xlsb"
            FileCopy sLocalPath & sFileName, sNASFile
    
            EmailFileFromAssurance "RBD - " & sUnitName, sMessage, sLeadCOMEmailAddress, sLocalPath & sFileName, True
            
         With ThisWorkbook.Sheets(sSheetname)
             .Range("F" & iRowNo).Value = Now()
        End With
           
            
            'MsgBox "Email Sent to " & sUnitName & " Lead COM - " & vbLf & vbLf & sLeadCOMEmailAddress
        End If
    
    Next iRowNo
LockSht
Macro_End_Settings

End Function



Function RemoveBackgroundLinks(wb As Workbook)

    Dim ws As Worksheet
    Dim KeepSheets As Variant
    Dim s As Variant
    
Macro_Start_Settings

   ' List the sheets you want to freeze
    KeepSheets = Array("Unit Summary", "DO Demand", "DO Supply", "Confirmation")
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    For Each s In KeepSheets
        Set ws = wb.Worksheets(CStr(s))
        ws.Unprotect SheetPWD
        ws.UsedRange.Value = ws.UsedRange.Value
    Next s

End Function


Function DeleteBackgroundSheets(wb As Workbook)

    Dim ws As Worksheet

Macro_Start_Settings

    For Each ws In wb.Worksheets
        If LCase(Left(ws.CodeName, 2)) = "h_" Then
            ws.Visible = xlSheetHidden
            ws.Delete
        End If
    Next ws

End Function


Function LockWorkbook(wb As Workbook)

   Dim sht As Worksheet
Macro_Start_Settings
   
   For Each sht In wb.Worksheets
      If Not VBA.Left(sht.CodeName, 2) = "h_" Then
         With sht
            .Visible = True
            .Protect Password:=SheetPWD, AllowSorting:=True, AllowFiltering:=True, UserInterfaceOnly:=True, DrawingObjects:=False
         End With
      Else
         sht.Visible = xlSheetVeryHidden
      End If
   Next
   
End Function



Function RestoreFormulae(wb As Workbook)
Macro_Start_Settings

     With wb.Sheets("DO Demand")
        .Unprotect SheetPWD
        .Range("W3:AF3").FormulaR1C1 = "=COUNTIF(R11C:R300C,""YES"")"
        .Range("AH3:AH3").FormulaR1C1 = "=COUNTIF(R11C:R300C,""YES"")"
        
        .Range("W4:AF4").FormulaR1C1 = "=COUNTIF(R11C:R300C,""NO"")"
        .Range("AH4:AH4").FormulaR1C1 = "=COUNTIF(R11C:R300C,""NO"")"
        
        

       Dim SEP As String
       SEP = Application.International(xlListSeparator)
              
    
        .Range("AG3").Formula2 = _
           "=LET(" & _
           "r" & SEP & "AG11:AG500" & SEP & _
           "u" & SEP & "UNIQUE(FILTER(r" & SEP & "r<>""""))" & SEP & _
           "c" & SEP & "COUNTIF(r" & SEP & "u)" & SEP & _
           "s" & SEP & "SORTBY(u" & SEP & "c" & SEP & "-1)" & SEP & _
           "sc" & SEP & "SORTBY(c" & SEP & "c" & SEP & "-1)" & SEP & _
           "TAKE(s & "" ("" & sc & "")""" & SEP & "3))"
       
        .Range("AI3").Formula2 = _
           "=LET(" & _
           "r" & SEP & "AI11:AI500" & SEP & _
           "u" & SEP & "UNIQUE(FILTER(r" & SEP & "r<>""""))" & SEP & _
           "c" & SEP & "COUNTIF(r" & SEP & "u)" & SEP & _
           "s" & SEP & "SORTBY(u" & SEP & "c" & SEP & "-1)" & SEP & _
           "sc" & SEP & "SORTBY(c" & SEP & "c" & SEP & "-1)" & SEP & _
           "TAKE(s & "" ("" & sc & "")""" & SEP & "3))"
    End With
    
    With wb.Sheets("DO Supply")
        .Unprotect SheetPWD
        .Range("O3:O17").FormulaR1C1 = "=IF(ISNUMBER(RC[-1]), RC[-1]-RC[-2], """")"
        .Range("O18").FormulaR1C1 = "=SUM(R[-15]C:R[-1]C)"
        .Range("M18").FormulaR1C1 = "=SUM(R[-15]C:R[-1]C)"
        .Range("N18").FormulaR1C1 = "=IF(SUM(R[-15]C:R[-1]C)>0,SUM(R[-15]C:R[-1]C),"""")"
        .Range("N21:N27").FormulaR1C1 = "=COUNTBLANK(RC[-1])"
        .Range("M29").FormulaR1C1 = "=COUNTBLANK(R[-1]C)"
        .Range("N29").FormulaR1C1 = "=IF(R[-1]C[-1]=""No"",COUNTBLANK(R[-1]C),"""")"
        .Range("N20").FormulaR1C1 = "=SUM(R[1]C:R[7]C,R[9]C[-1],R[9]C)"
    End With
    
    With wb.Sheets("Confirmation")
        .Unprotect SheetPWD
        .Range("K17").FormulaR1C1 = "='DO Demand'!R[-7]C[25]+'DO Supply'!R[3]C[3]"
        .Range("K18").FormulaR1C1 = "=IF(R[-1]C>0,""Review DO Demand & DO Supply"","" "")"
    End With

    
End Function

Function ExtractWalkData()

Dim vWalkDetails As Variant
Dim iLastRow As Integer
Dim sESFS As String

Macro_Start_Settings

    With ThisWorkbook.Sheets("DO Demand")
        sESFS = .Range("K11").Value
        iLastRow = LastUsedRow(ThisWorkbook.Sheets("DO Demand"), "B")
        vWalkDetails = .Range("B10:AI" & iLastRow)
    End With

UploadArray2NetworkFile sMarsPath & "_SQL\RBDWalks\", sESFS & "-RBDWalkExtract", vWalkDetails, "csv"

Macro_End_Settings

End Function



Function ConfirmSignatures() As Boolean

    Dim wsConfirm As Worksheet
    Dim shp As Shape
    Dim sCOMSigned As Boolean, sCWUSigned As Boolean
       
    Set wsConfirm = ThisWorkbook.Worksheets("Confirmation")

    sCOMSigned = False
    sCWUSigned = False
   
    For Each shp In wsConfirm.Shapes

        If shp.TopLeftCell.Address(False, False) = "B20" Then sCOMSigned = True
        If shp.TopLeftCell.Address(False, False) = "B25" Then sCWUSigned = True
            
    Next shp
    
    If sCOMSigned = True And sCWUSigned = True Then
        ConfirmSignatures = True
    Else
        ConfirmSignatures = False
        If sCOMSigned = False Then MsgBox "No COM Signature Found"
        If sCWUSigned = False Then MsgBox "No CWU Rep Signature Found"
    End If
End Function




Attribute VB_Name = "zFileFunctions"
'Various admin functions relating to this file specifically

Public Const sMasterPath As String = "\\ng92rrdc1\RcsReceipt\OpsTrans\"
Public Const sLocalPath As String = "C:\Users\Public\Downloads\"
Public Const sMarsPath As String = "\\ng92rrdc1\DELIVERY\DATA\MARS\"

Public Const sAppTLA As String = "RBD"
Public Const SheetPWD As String = "Mar$"

Public m_objWalkData As C_Import_Data

Option Explicit




Function StandardStart()

Application.EnableEvents = False
    adminclose
    
'    Macro_Start_Settings "Checking File Status..."
    
    If (CheckAndCreateFolder(sLocalPath) = False) Then MsgBox "Cannot Create Local Path"
    
    If (OpenAsAdmin = True) Then
        adminopen
    Else
    
        If UseronRMGNetwork = False Then
            MsgBox "You must be connected to a Royal Mail Network to use DPT - please connect and try again"
        Else
            RefreshUnitData
            CheckForVersionUpdates
        End If
    End If
        
    Macro_End_Settings True

End Function

Function ToolAdmin()

Dim ws As Worksheet

Macro_Start_Settings


Macro_End_Settings
 
End Function

Function GetUnitPriority() As String

    GetUnitPriority = ThisWorkbook.Sheets("UnitConfig #h").Range("B3").Value

End Function
Function GetRODName() As String

    GetRODName = ThisWorkbook.Sheets("DO Demand").Range("B4").Value

End Function
Function GetDeliverySummaryName() As String

    GetDeliverySummaryName = ThisWorkbook.Sheets("DO Demand").Range("B2").Value

End Function

Function GetESFS() As String

    GetESFS = ThisWorkbook.Sheets("Unit Summary").Range("G3").Value

End Function



Function GetDPTMode() As String

    With ThisWorkbook.Sheets("UnitConfig #h")
    
        Select Case .Range("B3")
            Case "P1"
                GetDPTMode = "PRIORITY"
            Case "P2", "P3"
                GetDPTMode = "BAU"
            Case "PLT"
                GetDPTMode = "PILOT"
            Case Else
                GetDPTMode = "NOT IN PLAN"
        End Select
    
    End With

End Function

Function SetDPTMode()

'Dim b163Unit As Boolean
'
'
'With ThisWorkbook
'
'    b163Unit = IIf(GetDPTMode = "PRIORITY", True, False)
'
'        .Sheets("Progress").Visible = Not b163Unit
'        With .Sheets("Process")
'            .Unprotect SheetPWD
'                .Visible = b163Unit
'                .ROWS("11:12").Hidden = b163Unit
'                .ROWS("26:26").Hidden = b163Unit
'            .Protect SheetPWD
'        End With
'        With .Sheets("Day AB Split")
'            .Unprotect SheetPWD
'                .Columns("O:R").Hidden = Not b163Unit
''                .Columns("R:R").Hidden = Not b163Unit
'        End With
'
'        .Sheets("My Challenge Alt").Visible = b163Unit
'        .Sheets("Duty Options Alt").Visible = b163Unit
'        .Sheets("Alt Duty Design").Visible = b163Unit
'        .Sheets("Route Design MtoF").Visible = b163Unit
'        .Sheets("Route Design Sat").Visible = b163Unit
'        .Sheets("Fleet Assurance").Visible = Not b163Unit
'
'        If GetDPTMode = "PILOT" Then .Sheets("Peak 5050").Visible = True
'
'        If b163Unit = True Then BAUProgressUpdate
'
'
'End With


End Function


Function BAUProgressUpdate()
    With Sheets("Process")
        .Unprotect SheetPWD
            .Range("G13:G14").FormulaR1C1 = "Confirmed"
            .Range("G15:G15").FormulaR1C1 = "Assured"
            .Range("G16:G16").FormulaR1C1 = "Complete"
            .Range("G17:G17").FormulaR1C1 = "Assured"
            .Range("G20:G22").FormulaR1C1 = "Complete"
        .Protect Password:=SheetPWD, AllowSorting:=True, AllowFiltering:=True, UserInterfaceOnly:=True, DrawingObjects:=False
    End With
End Function


Function AdminComplete()
'
' DPTProcessTabComplete Macro
'
    With Sheets("Process")
        .Unprotect SheetPWD
            .Range("H8").FormulaR1C1 = "Complete"
            .Range("H9").FormulaR1C1 = "Confirmed"
            .Range("H10").FormulaR1C1 = "Complete"
            .Range("H13").FormulaR1C1 = "Confirmed"
            .Range("H15").FormulaR1C1 = "Assured"
            .Range("H16").FormulaR1C1 = "Complete"
            .Range("H17").FormulaR1C1 = "Assured"
            .Range("H18").FormulaR1C1 = "Complete"
            .Range("G20").FormulaR1C1 = "Complete"
            .Range("H22").FormulaR1C1 = "Complete"
'            .Range("F23:G24").FormulaR1C1 = "Complete"
         .Protect Password:=SheetPWD, AllowSorting:=True, AllowFiltering:=True, UserInterfaceOnly:=True, DrawingObjects:=False
    End With
End Function


Function DPTCopytoNew(wbSource As Workbook, wbDestination As Workbook)

    If ThisWorkbook.Worksheets.Count = 7 Then
        DPTCopytoNew_UnitFile wbSource, wbDestination
    Else
        End
'        DPTCopytoNew_UnitFile WBSource, wbDestination
    End If

End Function

Function DPTCopytoNew_FULL(wbSource As Workbook, wbDestination As Workbook)

End Function


Function DPTCopytoNew_UnitFile(wbSource As Workbook, wbDestination As Workbook)

Dim sSht As String
Dim shtSource As Worksheet

Application.EnableEvents = False
Application.Calculation = xlCalculationManual

With wbDestination

'-----------------------------------------------------------------------------------------------------------
    sSht = "Unit Summary"
    
    On Error Resume Next
        Set shtSource = wbSource.Sheets(sSht)
        
            With .Sheets(sSht)
                .Unprotect SheetPWD
                    .Range("C3:F3").Value = shtSource.Range("C3:F3").Value
                    .Range("C6:H18").Value = shtSource.Range("C6:H18").Value
                    .Range("H23:H24").Value = shtSource.Range("H23:H24").Value
                    .Range("B30:C31").Value = shtSource.Range("B30:C31").Value
                    .Range("B34:C34").Value = shtSource.Range("B34:C34").Value
                    .Range("E30:H39").Value = shtSource.Range("E30:H39").Value
                    .Range("B37:C46").Value = shtSource.Range("B37:C46").Value
               .Protect Password:=SheetPWD, AllowFiltering:=True, AllowSorting:=True, DrawingObjects:=False
            End With
    On Error GoTo 0
 '-----------------------------------------------------------------------------------------------------------
    sSht = "DO Demand"
    
    On Error Resume Next
        Set shtSource = wbSource.Sheets(sSht)
        
            With .Sheets(sSht)
                .Unprotect SheetPWD
…