'=========================================================================
' GoogleSitemap.vbs
' VERSION: 1.0
' AUTHOR: Brian Steinmeyer
' EMAIL: sigkill@sigkillit.com
' WEB: http://sigkillit.com
' DATE: 4/1/2012
' COMMENTS: Traverse a local website root folder and generates a Google
' Sitemap .xml file based on the folder structure. Modify the variables
' in the settings section accordingly. The variables are explained below:
' conLocalRoot - Local Website Root Folder
' conSitemap - Google Sitemap XML file to output
' conDefaultChangeFreq - Default Change Frequency for Sitemap
' conDefaultPriority - Default Priority for Sitemap
' blnSortAtoZ - Option to sort the sitemap alphabetically
' arrValidFileExtension - list of Valid file extensions to include int he sitemap
' arrDefaultDocument - list of valid default document names which are not added to the sitemap
' arrExcludedFolder - List of folders to exclude from the sitemap
' arrExcludedFile - List of file names to exclude from the sitemap
'=========================================================================
Option Explicit
' ------ SCRIPT CONFIGURATION ------
Const conLocalRoot = "C:\inetpub\wwwroot\"
Const conSitemap = "C:\inetpub\wwwroot\sitemap.xml"
Const conWebsiteFQDN = "http://www.domain.com/"
Const conDefaultChangefreq = "monthly"
Const conDefaultPriority = "0.5"
Const blnSortAtoZ = False
Dim arrValidFileExtension: arrValidFileExtension = array("php","asp","aspx","htm","html","shtml")
Dim arrDefaultDocument: arrDefaultDocument = array("index.php","index.asp","index.aspx","index.htm","index.html","index.shtml")
Dim arrExcludedFolder: arrExcludedFolder = array("_includes","css","images")
Dim arrExcludedFile: arrExcludedFile = array("404.php")
' ------ END CONFIGURATION ------

'Validate Arrays
Dim blnValidFileExtensionIsArray: blnValidFileExtensionIsArray = False
Dim blnDefaultDocumentIsArray: blnDefaultDocumentIsArray = False
Dim blnExcludedFolderIsArray: blnExcludedFolderIsArray = False
Dim blnExcludedFileIsArray: blnExcludedFileIsArray = False
If IsArray(arrValidFileExtension) Then
    blnValidFileExtensionIsArray = True
End If
If IsArray(arrDefaultDocument) Then
    blnDefaultDocumentIsArray = True
End If
If IsArray(arrExcludedFolder) Then
    blnExcludedFolderIsArray = True
End If
If IsArray(arrExcludedFile) Then
    blnExcludedFileIsArray = True
End If

'Crawl Local Webroot Folder
Dim arrResults()
Call CrawlFolder(conLocalRoot, 0, arrResults)

'Optionally Sort Results Array - Maybe Move this
If blnSortAtoZ = True Then
    Call BubbleSort(arrResults)
End If

'Write Sitemap XML File
WriteSiteMap(arrResults)

'End Script
Wscript.Echo "Finished"

Private Function CrawlFolder(FolderToCrawl, intFiles, ByRef arrFiles)

    'Start Crawling Folder
   Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim objFolder: Set objFolder = objFSO.GetFolder(FolderToCrawl) 
    Dim blnFolderIsExcluded: blnFolderIsExcluded = False

    'Check If We Should Exclude This Folder
    If blnExcludedFolderIsArray = True Then
        Dim strExcludedFolder
        For Each strExcludedFolder in arrExcludedFolder
            If StrComp(objFolder.Name,strExcludedFolder,1) = 0 Then
                blnFolderIsExcluded = True
            End If
        Next
    End If

    'Parse Files in Folder
   If blnFolderIsExcluded = False Then

        Dim objFiles: Set objFiles = objFolder.Files
        Dim objFile, strResult
        Dim strDefaultDocument, strValidFileExtension, strExcludedFile
        Dim blnFileIsExcluded, blnFileExtensionIsValid, blnDefaultDocument

        For Each objFile In objFiles

            blnFileIsExcluded = False
            blnFileExtensionIsValid = False
            blnDefaultDocument = False
            strResult = ""

            'Check If We Should Exclude This File
            If blnExcludedFileIsArray = True Then
                For Each strExcludedFile in arrExcludedFile
                    If StrComp(objFile.Name,strExcludedFile,1) = 0 Then
                        blnFileIsExcluded = True
                    End If
                Next
            End If

            'Check If We Should Exclude This File Extension
            If blnValidFileExtensionIsArray = True Then
                For Each strValidFileExtension in arrValidFileExtension
                    If StrComp(objFSO.GetExtensionName(objFile.Name),strValidFileExtension,1) = 0 Then
                        blnFileExtensionIsValid = True
                    End If
                Next
            End If             

            If blnFileIsExcluded = False AND blnFileExtensionIsValid = True Then
                strResult = objFile.Path
                ReDim Preserve arrFiles(intFiles)
                arrFiles(intFiles) = strResult
                intFiles = intFiles + 1
            End If
        Next

        'Crawl Subfolders
        Dim objSubFolder
        For Each objSubFolder In objFolder.SubFolders
            Call CrawlFolder(objSubFolder.Path, intFiles, arrResults)
        Next

    End If

    CrawlFolder = arrFiles

    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFiles = Nothing

End Function

Private Sub WriteSiteMap(arrSites)

    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(conSitemap) Then
        Dim strPath, strUrl, objNodeLoc, objNodeLastmod
        Dim xmlDoc: Set xmlDoc = CreateObject("Microsoft.XMLDOM")
        xmlDoc.preserveWhiteSpace = False
        xmlDoc.Async = False
        Dim arrAppend()
        Dim intAppend: intAppend = 0
        If xmlDoc.Load(conSitemap) Then
            For Each strPath in arrSites
                strUrl = ConvertLocalPathToUrl(strPath)
                Set objNodeLoc = xmlDoc.selectSingleNode("/urlset/url " & "[loc = '" & strUrl & "']")
                If Not objNodeLoc Is Nothing then
                    'Found a Match Update the Date
                    Set objNodeLastmod = xmlDoc.selectSingleNode("/urlset/url " & "[loc = '" & strURL & "']/lastmod")
                    If Not objNodeLastmod Is Nothing Then  
                        objNodeLastmod.Text = GetDate(objFSO.GetFile(strPath).DateLastModified)
                    End If
                    xmlDoc.Save conSitemap
                Else
                    'Append URL to sitemap.xml
                    Dim objRoot: Set objRoot = xmlDoc.documentElement
                    Dim objRecord: Set objRecord = xmlDoc.createElement("url")
                    'objRecord.setAttribute "xmlns", "http://www.sitemaps.org/schemas/sitemap/0.9")
                    objRoot.appendChild objRecord
                    Dim objFieldValue
                    'Location
                    Set objFieldValue = xmlDoc.createElement("loc")
                    objFieldValue.Text = strUrl
                    objRecord.appendChild objFieldValue
                    'Last Modified
                    Set objFieldValue = xmlDoc.createElement("lastmod")
                    objFieldValue.Text = GetDate(objFSO.GetFile(strPath).DateLastModified)
                    objRecord.appendChild objFieldValue
                    'Change Frequency
                    Set objFieldValue = xmlDoc.createElement("lastmod")
                    objFieldValue.Text = conDefaultChangefreq
                    objRecord.appendChild objFieldValue
                    'Priority
                    Set objFieldValue = xmlDoc.createElement("lastmod")
                    objFieldValue.Text = conDefaultPriority
                    objRecord.appendChild objFieldValue                
                    'Save Sitemap.xml
                    xmlDoc.Save conSitemap
                End If
            Next       
        Else
            Wscript.Echo "Error Loading sitemap.xml Or sitemap.xml is NOT valid XML"
        End If
        'Cheap Hack to Cleanup Appends
        Set xmlDoc = Nothing
        Dim objTextFile: Set objTextFile = objFSO.OpenTextFile(conSitemap, 1)
        Dim strText: strText = objTextFile.ReadAll
        objTextFile.Close
        strText = Replace(strText," xmlns=" & chr(34) & chr(34),"")
        Set objTextFile = objFSO.OpenTextFile(conSitemap, 2)
        objTextFile.Write strText
        objTextFile.Close
    Else
        'Make New Sitemap File
        Call Logger(conSitemap,"<?xml version=" & chr(34) & "1.0" & chr(34) & " encoding=" & chr(34) & "UTF-8" & chr(34) & "?>",True)
        Call Logger(conSitemap,"<urlset xmlns=" & chr(34) & "http://www.sitemaps.org/schemas/sitemap/0.9" & chr(34) & ">",False)
        Dim strLoc
        For Each strLoc in arrSites
            Call Logger(conSitemap,vbTab & "<url>",False)
            Call Logger(conSitemap,vbTab & vbTab & "<loc>" & ConvertLocalPathToUrl(strLoc) & "</loc>",False)
            Call Logger(conSitemap,vbTab & vbTab & "<lastmod>" & GetDate(objFSO.GetFile(strLoc).DateLastModified) & "</lastmod>",False)
            Call Logger(conSitemap,vbTab & vbTab & "<changefreq>" & conDefaultChangefreq & "</changefreq>",False)
            Call Logger(conSitemap,vbTab & vbTab & "<priority>" & conDefaultPriority & "</priority>",False)
            Call Logger(conSitemap,vbTab & "</url>",False)
        Next
        Call Logger(conSitemap,"</urlset>",False)
    End If

    Set objFSO = Nothing

End Sub

Private Function ConvertLocalPathToUrl(strPath)

    'Check If File is Default Document
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim strDefaultDocument
    Dim blnDefaultDocument: blnDefaultDocument = False
    If blnDefaultDocumentIsArray = True Then
        For Each strDefaultDocument in arrDefaultDocument
            If StrComp(objFSO.GetFileName(strPath),strDefaultDocument,1) = 0 Then
                blnDefaultDocument = True
            End If
        Next
    End If

    'Return Results
    Dim strResult: strResult = ""
    strResult = Replace(strPath,conLocalRoot,conWebsiteFQDN,1,1,1)
    strResult = Replace(strResult,"\","/")
    If blnDefaultDocument = True Then
        strResult = Replace(strResult,objFSO.GetFileName(strPath),"")
    End If

    ConvertLocalPathToUrl = strResult

    Set objFSO = Nothing

End Function

Private Function BubbleSort(ByRef arrValues)

    Dim j, k, Temp
    For j = 0 To UBound(arrValues) - 1
        For k = j + 1 To UBound(arrValues)
            If (arrValues(j) > arrValues(k)) Then
                Temp = arrValues(j)
                arrValues(j) = arrValues(k)
                arrValues(k) = Temp
            End If
        Next
    Next

    BubbleSort = arrValues

End Function

Private Function GetDate(strDate)

    'Ensure Valid Date
    If Not IsDate(strDate) Then
        strDate = Date
    End If

    Dim strYear: strYear = Year(strDate)
    Dim strMonth: strMonth = Month(strDate)
    Dim strDay: strDay = Day(strDate)
    If strMonth < 10 Then
        strMonth = 0 & strMonth
    End If
    If strDay < 10 Then
        strDay = 0 & strDay
    End If

    GetDate = strYear & "-" & strMonth & "-" & strDay

End Function

Private Sub Logger(fileName, logMessage, blnNewLog)

    On Error Resume Next

    Const ForReading = 1, ForWriting = 2, ForAppending = 8
    Dim objFSO: Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim scriptPath: scriptPath = Left(WScript.ScriptFullName,InstrRev(WScript.ScriptFullName,"\"))
    Dim logName
    If InStr(1,fileName,"\",1) > 0 Then
        logName = fileName
        If objFSO.DriveExists(objFSO.GetDriveName(logName)) Then
            If StrComp(objFSO.GetExtensionName(logName), "", 1) = 0 Then
                If Not objFSO.FolderExists(logName) Then
                    If objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        objFSO.CreateFolder logName 'Create Folder In Current Path
                        Exit Sub
                    Else
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog) 'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog) 'Recurse Creating Current Folder
                        Exit Sub
                    End If
                End If
            Else
                If Not objFSO.FileExists(logName) Then
                    If Not objFSO.FolderExists(objFSO.GetParentFolderName(logName)) Then
                        Call Logger(objFSO.GetParentFolderName(logName), logMessage, blnNewLog)  'Recurse Creating Parent Folder
                        Call Logger(logName, logMessage, blnNewLog)  'Recurse Creating Current Folder
                    End If
                End If
            End If
        End If
    Else
        logName = scriptPath & fileName
    End If
    Dim logFile
    If blnNewLog = True Then
        Set logFile = objFSO.CreateTextFile(logName, True)
    Else
        If objFSO.FileExists(logName) Then
            Set logFile = objFSO.OpenTextFile(logName, ForAppending, True)
        Else
            Set logFile = objFSO.CreateTextFile(logName, True)
        End If
    End If
    logFile.WriteLine logMessage
    logFile.Close
    Set objFSO = Nothing

    On Error Goto 0

End