'=========================================================================
' 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