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

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'log close
    libLog.logUsage 4
End Sub

Private Sub Workbook_Open()

    'sometimes excel first opens a blank workbook called "BOOK1" - check if book1 auto opened and close
    closeBook1
    
    'check if excel open already and close if it is.
    checkIfExcelOpenMultipleTimes
    
    'close window
    Application.Visible = False
    
    'ENSURE MAP WORKSHEET IS FIRST TO OPEN
    Worksheets("map").Activate
    
    'show loadupscreen
    fmSplash.Show

    'checkfornew
    checkForNewVersion
    
    'check first run?
    'POSSIBLE FOR LATER VERSION
    If libLog.checkUser(getUser) = False Then
        'need to add
        fmFirstTime.Show
        libLog.logUser
    End If
''''
    'view application
    Application.Visible = True
    
    'fullscreen excel
    Title_Hide
    
    'check for change log
    libLog.checkUpdateChangeLog
    
    'load userforms
    fmOptions.Show vbModeless
    
    'bring options userform to top
    FrameToTop
    
End Sub

Attribute VB_Name = "fmAbout"
Attribute VB_Base = "0{7018358B-68CF-40E0-B40A-9B2C253E2DF4}{D83B5170-6F05-4253-A1E1-34F13CB12BA7}"
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 cbBench_Click()
    If running Then
        MsgBox "Please first stop running before trying to run a benchmark test", vbInformation
    Else
        fmBench.Show vbModeless
    End If
End Sub

Private Sub cbClearData_Click()
    'clear flag for newly updated screen
    Worksheets("info").Range("C2") = False
    'removed list of previously opened
    Worksheets("useLog").Range("A2:A" & Worksheets("useLog").Cells(Rows.count, 1).End(xlUp).Row).ClearContents
End Sub

Private Sub cbTutorial_Click()
    fmFirstTime.Show vbModeless
End Sub

Private Sub CommandButton1_Click()
    fmFeedback.Show vbModeless
End Sub

Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    ActiveWorkbook.FollowHyperlink Address:="https://www.facebook.com/lewisgmorris"
End Sub
Private Sub Image2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    ActiveWorkbook.FollowHyperlink Address:="http://www.schipshop.co.uk/blog"
End Sub
Private Sub Image3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    ActiveWorkbook.FollowHyperlink Address:="mailto:lewis.morris@gmail.com"
End Sub

Private Sub lbBlog_Click()
    ActiveWorkbook.FollowHyperlink Address:="http://www.schipshop.co.uk/blog"
End Sub
Private Sub lbEmail_Click()
    ActiveWorkbook.FollowHyperlink Address:="mailto:lewis.morris@gmail.com"
End Sub
Private Sub lbFace_Click()
    ActiveWorkbook.FollowHyperlink Address:="https://www.facebook.com/lewisgmorris"
End Sub

Private Sub UserForm_Activate()
    Me.lbVersion.Caption = libLog.getCurrentVersion
End Sub

Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim lr As Integer
Dim x As Integer
Dim tbString As String
    Set ws = Worksheets("Change Log")
    lr = ws.Cells(Rows.count, 1).End(xlUp).Row
    For x = 1 To lr
        tbString = tbString & ws.Cells(x, 1) & "- Version :" & ws.Cells(x, 3) & vbNewLine & ws.Cells(x, 2) & vbNewLine & vbNewLine
    Next x
    Me.tbChange.value = tbString
    
'set userform load position
    Me.StartUpPosition = 0
    Me.Left = Application.Left + (0.5 * Application.Width) - (0.5 * Me.Width)
    Me.Top = Application.Top + (0.5 * Application.Height) - (0.5 * Me.Height)
    
'set height for later user
lbInitHeight.Caption = Me.Height
'set arrow up position
showUp imgUp, imgDown, Me, True

End Sub
Private Sub imgDown_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    showUp imgUp, imgDown, Me
End Sub
Private Sub imgUp_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
    showDown imgUp, imgDown, Me
End Sub

     

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


Attribute VB_Name = "libFunctions"
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

#If VBA7 Then
    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
    Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If

Option Compare Text

Sub SleepTest(sleepTime As Double)

    Sleep sleepTime 'delay in milliseconds

End Sub

Function bruteForceCheckPercentage(lowVal, hiVal As Double)

Dim percChange As Double
Dim newVal As Double

percChange = 0.99999

If hiVal < lowVal Then
    bruteForceCheckPercentage = "Price already lower"
    Exit Function
End If

For x = 1 To 9999999
    newVal = hiVal * percChange
    If VBA.Format(newVal, "0.00") = VBA.Format(lowVal, "0.00") Then
        bruteForceCheckPercentage = VBA.Format(1 - percChange, "0.00%")
        Exit Function
    End If
    percChange = percChange - 0.0001
Next x
End Function
Function returnDate(dte As String) As Date

Dim d, m, Y As Integer

d = VBA.Left(dte, 2)
Y = VBA.Right(dte, 4)
m = VBA.Mid(dte, 4, 2)

returnDate = DateSerial(Y, m, d)


End Function

Sub interactWithDatabase_Insert()

Dim sSQLQry As String
Dim Conn As New ADODB.Connection
Dim sconnect As String


'CONNECTION STRINGS CAN BE FOUND HERE!! WOOOO
'https://www.connectionstrings.com/visual-foxpro

sconnect = "Provider=vfpoledb;Data Source=C:\Users\Lewis\Desktop\comp_l.dbc;Collating Sequence=machine;"
Conn.Open sconnect
sSQLSting = "update l_ihead set ih_priorty = 6 where ih_sorder = 'ORDP952749' and ih_account = 'MED1A'" ' Your SQL Statement (Table Name= Sheet Name=[map$])

Conn.Execute sSQLSting, , adCmdText

'Close Connection
Conn.Close

End Sub
Sub interactWithDatabase_Select()

Dim sSQLQry As String
Dim ReturnArray
Dim Conn As New ADODB.Connection
Dim mrs As New ADODB.Recordset
Dim DBPath As String, sconnect As String


'
'CONNECTION STRINGS CAN BE FOUND HERE!! WOOOO
'https://www.connectionstrings.com/visual-foxpro


sconnect = "Provider=vfpoledb;Data Source=C:\Users\Lewis\Desktop\comp_l.dbc;Collating Sequence=machine;"
Conn.Open sconnect
sSQLSting = "SELECT * From l_ihead where ih_sorder = 'ORDP952749' and ih_account = 'MED1A'" ' Your SQL Statement (Table Name= Sheet Name=[map$])"
mrs.Open sSQLSting, Conn


'if you want in an array!
ReturnArray = mrs.GetRows
'cool

Range("A2").CopyFromRecordset mrs

For x = 0 To mrs.Fields.count - 1
    Cells(1, x + 1) = mrs.Fields(x).name
Next x

Dim lr As Integer

For x = 2 To UBound(ReturnArray, 2) + 2
    For Y = 0 To mrs.Fields.count - 1
        Cells(x, Y + 1) = ReturnArray(Y, x - 2)
    Next Y
Next x

'Close Recordset
mrs.Close
'Close Connection
Conn.Close

End Sub
Function sortRangeByColour()

Dim ws As Worksheet

For Each ws In ActiveWorkbook.Sheets
    lr = ws.Cells(Rows.count, 1).End(xlUp).Row
    ws.SORT.SortFields.Clear
    ws.SORT.SortFields.Add(ws.Range("A1:A" & lr), _
        xlSortOnCellColor, xlAscending, , _
        xlSortNormal).SortOnValue.Color = rgb(0, 222, 0)
    With ws.SORT
        .SetRange ws.Range("A1:I" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Next ws

End Function

Function readTextFile(filepath As String)

Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim txtStream As TextStream
Set txtStream = fso.OpenTextFile(filepath, ForReading, False)

Do While Not txtStream.AtEndOfStream
    txtStream.ReadLine
Loop
txtStream.Close

End Function

Public Function Similarity(ByVal String1 As String, _
    ByVal String2 As String, _
    Optional ByRef RetMatch As String, _
    Optional min_match = 1) As Single
Dim b1() As Byte, b2() As Byte
Dim lngLen1 As Long, lngLen2 As Long
Dim lngResult As Long

If UCase(String1) = UCase(String2) Then
    Similarity = 1
Else:
    lngLen1 = Len(String1)
    lngLen2 = Len(String2)
    If (lngLen1 = 0) Or (lngLen2 = 0) Then
        Similarity = 0
    Else:
        b1() = StrConv(UCase(String1), vbFromUnicode)
        b2() = StrConv(UCase(String2), vbFromUnicode)
        lngResult = Similarity_sub(0, lngLen1 - 1, _
        0, lngLen2 - 1, _
        b1, b2, _
        String1, _
        RetMatch, _
        min_match)
        Erase b1
        Erase b2
        If lngLen1 >= lngLen2 Then
            Similarity = lngResult / lngLen1
        Else
            Similarity = lngResult / lngLen2
        End If
    End If
End If

End Function

Private Function Similarity_sub(ByVal start1 As Long, ByVal end1 As Long, _
                                ByVal start2 As Long, ByVal end2 As Long, _
                                ByRef b1() As Byte, ByRef b2() As Byte, _
                                ByVal FirstString As String, _
                                ByRef RetMatch As String, _
                                ByVal min_match As Long, _
                                Optional recur_level As Integer = 0) As Long
'* CALLED BY: Similarity *(RECURSIVE)

Dim lngCurr1 As Long, lngCurr2 As Long
Dim lngMatchAt1 As Long, lngMatchAt2 As Long
Dim I As Long
Dim lngLongestMatch As Long, lngLocalLongestMatch As Long
Dim strRetMatch1 As String, strRetMatch2 As String

If (start1 > end1) Or (start1 < 0) Or (end1 - start1 + 1 < min_match) _
Or (start2 > end2) Or (start2 < 0) Or (end2 - start2 + 1 < min_match) Then
    Exit Function '(exit if start/end is out of string, or length is too short)
End If

For lngCurr1 = start1 To end1
    For lngCurr2 = start2 To end2
        I = 0
        Do Until b1(lngCurr1 + I) <> b2(lngCurr2 + I)
            I = I + 1
            If I > lngLongestMatch Then
                lngMatchAt1 = lngCurr1
                lngMatchAt2 = lngCurr2
                lngLongestMatch = I
            End If
            If (lngCurr1 + I) > end1 Or (lngCurr2 + I) > end2 Then Exit Do
        Loop
    Next lngCurr2
Next lngCurr1

If lngLongestMatch < min_match Then Exit Function

lngLocalLongestMatch = lngLongestMatch
RetMatch = ""

lngLongestMatch = lngLongestMatch _
+ Similarity_sub(start1, lngMatchAt1 - 1, _
start2, lngMatchAt2 - 1, _
b1, b2, _
FirstString, _
strRetMatch1, _
min_match, _
recur_level + 1)
If strRetMatch1 <> "" Then
    RetMatch = RetMatch & strRetMatch1 & "*"
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And (lngMatchAt1 > 1 Or lngMatchAt2 > 1) _
    , "*", "")
End If


RetMatch = RetMatch & Mid$(FirstString, lngMatchAt1 + 1, lngLocalLongestMatch)


lngLongestMatch = lngLongestMatch _
+ Similarity_sub(lngMatchAt1 + lngLocalLongestMatch, end1, _
lngMatchAt2 + lngLocalLongestMatch, end2, _
b1, b2, _
FirstString, _
strRetMatch2, _
min_match, _
recur_level + 1)

If strRetMatch2 <> "" Then
    RetMatch = RetMatch & "*" & strRetMatch2
Else
    RetMatch = RetMatch & IIf(recur_level = 0 _
    And lngLocalLongestMatch > 0 _
    And ((lngMatchAt1 + lngLocalLongestMatch < end1) _
    Or (lngMatchAt2 + lngLocalLongestMatch < end2)) _
    , "*", "")
End If

Similarity_sub = lngLongestMatch

End Function
Sub Mail_Selection_Range_Outlook_Body(rng1 As Range, email As String, subject, cc As String)
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = rng1
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

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

    On Error Resume Next
    With OutMail
        .To = email
        .cc = cc
        .BCC = ""
        .subject = subject
        .HTMLBody = RangetoHTML(rng)
        .send   'or use .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = VBA.Environ$("temp") & "\" & VBA.Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteVBA.FORMATs, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Function returnFileNameWithNoExtension(name As String)

Dim x As Integer

For x = 1 To Len(name)
    If VBA.Mid(name, x, 1) = "." Then Exit Function
    returnFileNameWithNoExtension = returnFileNameWithNoExtension & VBA.Mid(name, x, 1)
Next x

End Function




Sub BubbleSort(list())
'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim I As Long, j As Long
    Dim Temp As Long
    
    First = LBound(list)
    Last = UBound(list)
    For I = First To Last - 1
        For j = I + 1 To Last
            If list(I) > list(j) Then
                Temp = list(j)
                list(j) = list(I)
                list(I) = Temp
            End If
        Next j
    Next I
End Sub
Public Sub NonRecursiveFileSearch()

    Dim queue As Collection
    Dim fso As FileSystemObject
    Dim ofolder As Folder
    Dim osubfolder As Folder
    Dim ofile As File
    
    Set fso = New FileSystemObject
    Set queue = New Collection
     'obviously replace
    Dim ws As Worksheet
    Set ws = Worksheets("map")
    For x = 1 To 92
        queue.Add fso.GetFolder("U:\LBS Image Repository\Links\Links\")
        Do While queue.count > 0
            Set ofolder = queue(1)
            queue.remove 1 'dequeue
            '...insert any folder processing code here...
            For Each osubfolder In ofolder.SubFolders
                queue.Add osubfolder 'enqueue
            Next osubfolder
            For Each ofile In ofolder.Files
                If ofile.name Like ws.Cells(x, 1) & "*" Then
                    ofile.Copy "C:\Users\lewis.morris\Desktop\search folder\" & ofile.name
                    ws.Cells(x, 1).Interior.ColorIndex = 3
                End If
            Next ofile
        Loop
    Next x

End Sub
Function downloadImage(href As String, filename As String)

    downloadImage = URLDownloadToFile(0, href, filename, 0, 0)

End Function
Function downloadSmallerImageAndInsertIntoWorkbook()
Dim fldr As String
fldr = InputBox("What folder name on desktop would you like to save files into")
If fldr = "" Then
    MsgBox "error"
    End
End If

If Dir("C:\Users\lewis.morris\Desktop\" & "\" & fldr) = Empty Then
    MkDir "C:\Users\lewis.morris\Desktop\" & "\" & fldr
End If

For x = 1 To Cells(Rows.count, 1).End(xlUp).Row
    downloadImage "https://lbslondon.co.uk/LBS1/LBS1-SHOP/images/products/zoom/" & Replace(Cells(x, 1), "/", "") & ".JPG", "C:\Users\lewis.morris\Desktop\" & "\" & fldr & "\" & Replace(Cells(x, 1), "/", "") & ".JPG"
    On Error Resume Next
    DoEvents
    Dim opic As Shape
    Set opic = ActiveSheet.Shapes.AddPicture("C:\Users\lewis.morris\Desktop\" & "\" & fldr & "\" & Replace(Cells(x, 1), "/", "") & ".JPG", False, True, 1, 1, -1, -1)
        With opic
            .LockAspectRatio = msoTrue
            .Width = 75 * 1.5 - 2
            .Height = 100 * 1.5 - 2
            ActiveSheet.Cells(x, 1).EntireRow.RowHeight = 100 * 1.5
            ActiveSheet.Cells(x, 7).EntireColumn.ColumnWidth = 75
            .Left = ActiveSheet.Cells(x, "G").Left + 1
            .Top = ActiveSheet.Cells(x, "G").Top + 1
            .Placement = 1
        End With
    Set opic = Nothing
    Cells(x, 1).Activate
Next x
End Function

Function downloadHighQualityImageFromList()

Dim fldr As String
fldr = InputBox("What folder name on desktop would you like to save files into")
If fldr = "" Then
    MsgBox "error"
    End
End If

If Dir("C:\Users\lewis.morris\Desktop\" & "\" & fldr) = Empty Then
    MkDir "C:\Users\lewis.morris\Desktop\" & "\" & fldr
End If

For x = 1 To Cells(Rows.count, 1).End(xlUp).Row
    downloadImage "https://lbslondon.co.uk/LBS1/Original%20Images/l/products/" & Replace(Cells(x, 1), "/", "") & ".JPG", "C:\Users\lewis.morris\Desktop\" & "\" & fldr & "\" & Replace(Cells(x, 1), "/", "") & ".JPG"
    On Error Resume Next
    DoEvents
    Dim opic As Shape
    Set opic = ActiveSheet.Shapes.AddPicture("C:\Users\lewis.morris\Desktop\" & "\" & fldr & "\" & Replace(Cells(x, 1), "/", "") & ".JPG", False, True, 1, 1, -1, -1)
        With opic
            .LockAspectRatio = msoTrue
            .Width = 75 * 1.5 - 2
            .Height = 100 * 1.5 - 2
            ActiveSheet.Cells(x, 1).EntireRow.RowHeight = 100 * 1.5
            ActiveSheet.Cells(x, 7).EntireColumn.ColumnWidth = 75
            .Left = ActiveSheet.Cells(x, "G").Left + 1
            .Top = ActiveSheet.Cells(x, "G").Top + 1
            .Placement = 1
        End With
    Set opic = Nothing
    Cells(x, 1).Activate
Next x
End Function


Function checkIfExcelOpenMultipleTimes()



If countWorkbooksOpen > 1 Then
    MsgBox "You have more than one excel open please close them all before continuing.", vbCritical
    Application.Visible = True
    End
End If

If countExcelRunning > 1 Then
    MsgBox "You have more than one excel open please close them all before continuing.", vbCritical
    Application.Visible = True
    End
End If


End Function
Function countWorkbooksOpen()

Dim wb As Workbook
Dim x As Integer
For Each wb In Application.Workbooks
    countWorkbooksOpen = countWorkbooksOpen + 1
Next wb
End Function

Function countExcelRunning()
    Dim objList As Object

    Set objList = GetObject("winmgmts:") _
        .ExecQuery("select * from win32_process where name='excel.EXE'")

    If objList.count > 1 Then
        countExcelRunning = 2
    Else
        countExcelRunning = 1
    End If

End Function



Function searchGoogleMapsAddress(postcode As String, ByVal pos As Integer) As String

Dim oXMLHTTP As Object
Dim sPageHTML  As String
Dim sURL As String
Dim XmlMapResponse As String

postcode = Replace(postcode, "#", "")
postcode = Replace(postcode, "(", "")
postcode = Replace(postcode, ")", "")
postcode = Replace(postcode, "&", "")
postcode = Replace(postcode, "#", "")

sURL = "https://maps.googleapis.com/maps/api/geocode/xml?address=" & postcode & "&key=AIzaSyARFBFdxrKwiTgZ_hZP-JEzZt8C3ObMC3I"


Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
oXMLHTTP.Open "GET", sURL, False
oXMLHTTP.send
XmlMapResponse = oXMLHTTP.responseText

Dim strXML As String
Dim xNode As MSXML2.IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument60

strXML = XmlMapResponse

Set XDoc = New MSXML2.DOMDocument60
XDoc.LoadXML strXML
XDoc.LoadXML strXML
XDoc.LoadXML strXML

If Not XDoc.LoadXML(strXML) Then
    Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If

Dim xEmpDetails As MSXML2.IXMLDOMNode
Dim xEmployee As MSXML2.IXMLDOMNodeList


Set xEmpDetails = XDoc.DocumentElement
'On Error GoTo endme
Set xEmployee = XDoc.DocumentElement.ChildNodes

On Error GoTo endme
Worksheets("Sheet2").Cells(pos, "K") = XDoc.SelectSingleNode("/GeocodeResponse/result/VBA.FORMATted_address").text
Worksheets("Sheet2").Cells(pos, "L") = XDoc.SelectSingleNode("/GeocodeResponse/result/geometry/location/lat").text
Worksheets("Sheet2").Cells(pos, "M") = XDoc.SelectSingleNode("/GeocodeResponse/result/geometry/location/lng").text
Worksheets("Sheet2").Cells(pos, "N") = XDoc.SelectSingleNode("/GeocodeResponse/result/place_id").text

For x = 0 To XDoc.SelectNodes("/GeocodeResponse/result/type").length - 1
    Worksheets("Sheet2").Cells(pos, "O").Offset(0, x) = XDoc.SelectNodes("/GeocodeResponse/result/type").Item(x).text
Next x

For x = 0 To XDoc.SelectNodes("/GeocodeResponse/result/address_component").length - 1
    If InStr(XDoc.SelectNodes("/GeocodeResponse/result/address_component").Item(x).text, "country") > 0 Then
        Set xNode = XDoc.SelectNodes("/GeocodeResponse/result/address_component").Item(x)
        Worksheets("Sheet2").Cells(pos, "J") = xNode.ChildNodes.Item(0).text & " # " & xNode.ChildNodes.Item(1).text
    End If
Next x


endme:

'xEmpDetails.ChildNodes(1).definition
End Function

Function searchGoogleMapsContact(placeID As String) As String

Dim oXMLHTTP As Object
Dim sPageHTML  As String
Dim sURL As String
Dim XmlMapResponse As String

postcode = Replace(postcode, "#", "")
postcode = Replace(postcode, "(", "")
postcode = Replace(postcode, ")", "")
postcode = Replace(postcode, "&", "")
postcode = Replace(postcode, "#", "")

sURL = "https://maps.googleapis.com/maps/api/place/details/xml?placeid=" & placeID & "&fields=url,rating,VBA.FORMATted_phone_number,website,international_phone_number&key=AIzaSyARFBFdxrKwiTgZ_hZP-JEzZt8C3ObMC3I"

Set oXMLHTTP = CreateObject("MSXML2.ServerXMLHTTP")
oXMLHTTP.Open "GET", sURL, False
oXMLHTTP.send
XmlMapResponse = oXMLHTTP.responseText

Dim strXML As String
Dim xNode As MSXML2.IXMLDOMNode
Dim XDoc As MSXML2.DOMDocument60

strXML = XmlMapResponse

Set XDoc = New MSXML2.DOMDocument60
XDoc.LoadXML strXML
XDoc.LoadXML strXML
XDoc.LoadXML strXML

If Not XDoc.LoadXML(strXML) Then
    Err.Raise XDoc.parseError.ErrorCode, , XDoc.parseError.reason
End If

Dim xEmpDetails As MSXML2.IXMLDOMNode
Dim xEmployee As MSXML2.IXMLDOMNodeList


Set xEmpDetails = XDoc.DocumentElement
'On Error GoTo endme
Set xEmployee = XDoc.DocumentElement.ChildNodes

On Error GoTo endme
Worksheets("Sheet2").Cells(pos, "K") = XDoc.SelectSingleNode("/GeocodeResponse/result/VBA.FORMATted_address").text
Worksheets("Sheet2").Cells(pos, "L") = XDoc.SelectSingleNode("/GeocodeResponse/result/geometry/location/lat").text
Worksheets("Sheet2").Cells(pos, "M") = XDoc.SelectSingleNode("/GeocodeResponse/result/geometry/location/lng").text
Worksheets("Sheet2").Cells(pos, "N") = XDoc.SelectSingleNode("/GeocodeResponse/result/place_id").text

For x = 0 To XDoc.SelectNodes("/GeocodeResponse/result/type").length - 1
    Worksheets("Sheet2").Cells(pos, "O").Offset(0, x) = XDoc.SelectNodes("/GeocodeResponse/result/type").Item(x).text
Next x

For x = 0 To XDoc.SelectNodes("/GeocodeResponse/result/address_component").length - 1
    If InStr(XDoc.SelectNodes("/GeocodeResponse/result/address_component").Item(x).text, "country") > 0 Then
        Set xNode = XDoc.SelectNodes("/GeocodeResponse/result/address_component").Item(x)
        Worksheets("Sheet2").Cells(pos, "J") = xNode.ChildNodes.Item(0).text & " # " & xNode.ChildNodes.Item(1).text
    End If
Next x


endme:

'xEmpDetails.ChildNodes(1).definition
End Function


Function rndBetween(lowerbound, upperbound As Long)
    Randomize
    rndBetween = Int((upperbound - lowerbound + 1) * rnd + lowerbound)
    
End Function

Function getSecondsFromTimeString(time As String)

Dim hours, minutes, seconds As String
Dim timearr() As String
timearr = Split(time, ":")

seconds = timearr(2)
minutes = timearr(1) * 60
hours = timearr(0) * 3600

getSecondsFromTimeString = seconds + minutes + hours



End Function

Sub BubbleSort1(list() As worker)

'   Sorts an array using bubble sort algorithm
    Dim First As Integer, Last As Long
    Dim I As Long, j As Long
    Dim Temp As worker
    
    First = LBound(list)
    Last = UBound(list)
    For I = First To Last - 1
        For j = I + 1 To Last
            If list(I).initialDistance > list(j).initialDistance Then
                Set Temp = list(j)
                Set list(j) = list(I)
                Set list(I) = Temp
            End If
        Next j
    Next I
End Sub


Function closeBook1()

Dim wb As Workbook
    For Each wb In Application.Workbooks
        If wb.name = "Sheet1" Then
            Application.DisplayAlerts = False
            wb.Close
            Application.DisplayAlerts = True
        End If
    Next wb
End Function

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

Public xLoc, yLoc As Integer
Public cityNo As String
Public startPoint As Boolean



Attribute VB_Name = "libBoard"
Option Explicit

Function colourRangeDarker(rng As Range, places As Integer)
Dim rcell As Range

Dim r, g, b As Integer


    For Each rcell In rng.Cells
        If rcell.Interior.Color <> cityColour And rcell.Interior.Color <> cityOuterLimits Then
            wRGB rcell, r, g, b
            Select Case rcell.Interior.Color
                Case backColour
                    r = Int((255 / places) * drawLineNo)
                    b = Int((255 / places) * drawLineNo)
                    g = Int((255 / places) * drawLineNo)
                Case Else
                    If (b * 0.5) + Int((255 / places) * drawLineNo) > 255 Then
                        b = Int((255 / places) * drawLineNo) - (b * 0.5)
                    Else
                        b = (b * 0.5) + Int((255 / places) * drawLineNo)
                    End If
                    If (r * 0.5) + Int((255 / places) * drawLineNo) > 255 Then
                        r = Int((255 / places) * drawLineNo) - (r * 0.5)
                    Else
                        r = (r * 0.5) + Int((255 / places) * drawLineNo)
                    End If
                    If (g * 0.5) + Int((255 / places) * drawLineNo) > 255 Then
                        g = Int((255 / places) * drawLineNo) - (g * 0.5)
                    Else
                        g = (g * 0.5) + Int((255 / places) * drawLineNo)
                    End If
            End Select

            rcell.Interior.Color = rgb(r, g, b)
            drawLineNo = drawLineNo + 1
            'rcell.Interior.Color = rgb((rcell.Interior.Color Mod 256) * 0.5, (rcell.Interior.Color / 256 Mod 256) * 0.5, (255 / (towns * 2)) * drawLineNo)
            'rcell.Interior.Color = rgb(r * 0.1, g * 0.1, b * 0.1)
            'rcell.Interior.Color = rgb(50, 50, 50)
            'Sleep 1
        End If
        DoEvents
    Next rcell
End Function
Function wRGB(rng As Range, r, g, b As Integer)
 Dim intColor As Long
 Dim rgb As String
 intColor = rng.Interior.Color
 r = intColor And 255
 g = intColor \ 256 And 255
 b = intColor \ 256 ^ 2 And 255
 
End Function
Function paintMap(Optional prettyBack As Boolean, Optional zoom As Boolean)
Dim rcell As Range
Dim ws As Worksheet
Set ws = Worksheets("Map")
Dim rng As Range

'paints the map ignoring cells with the colour of the cities
    Application.ScreenUpdating = False
    
    Set rng = ws.Range(ws.Cells(2, 2), ws.Cells(heightOfMap + 2, widthOfMap + 2))
    
    If prettyBack Then
        For Each rcell In rng.Cells
            If rcell.Interior.Color <> cityColour And rcell.Interior.Color <> cityOuterLimits Then
                rng.Interior.Color = rgb(rndBetween(Int(90 * 0.85), Int(90 * 1.15)), rndBetween(Int(168 * 0.85), Int(168 * 1.15)), rndBetween(Int(45 * 0.85), Int(45 * 1.15)))
            End If
        Next rcell
    Else
        rng.Interior.Color = backColour
    End If
    
    With rng
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
…