DHCP failover script - Visual Basic Snipplr Social Repository

Revision: 65330

at November 20, 2013 11:25 by luckygreentiger

Updated Code

' Script created by floyd (luckygreentiger at gmail)
' This should allow a Windows server 2008+ act as a failover
' server for another (primary) DHCP server. The code should work
' but is untested. It was going to be used for work but ultimately
' fell through before it could be used. I am posting it for people
' to use in the hopes someone gets use out of it. If you do use it
' let me know please! This may (possibly) work for 2003+ too. For use
' as-is. No promises to work implied or given. Given freely but
' I am not liable for any damage done with this script.
' 19 November 2013

' If you find errors and want to make corrections please email
' me at the included email address (above). Thank you.

' DECLARE GLOBAL VARIABLES
dim strStatus, strBytes, strTime, strTTL, strHostPrimary
dim bFailover, bDone
dim loopMinutes, leaseMinutes
dim mailMessage, mailRelay

bDone = false


' DECLARED FUNCTIONS OF SCRIPT
' function from http://larsmichelsen.com/vbs/quickie-how-to-ping-a-host-in-vbs-i-got-two-ways/
' uses WMI to ping a server string and returns false for failure; and true for success
function Ping(strHostPrimary)
    dim oPing, oRetStatus, bReturn
    set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address='" & strHostPrimary & "'")
 
    for each oRetStatus in oPing
        if IsNull(oRetStatus.StatusCode) or oRetStatus.StatusCode <> 0 then
            bReturn = false
			strStatus = oRetStatus.StatusCode
        else
            bReturn = true
			strBytes = oRetStatus.BufferSize
            strTime = oRetStatus.ResponseTime
            strTTL = oRetStatus.ResponseTimeToLive
        end if
        set oRetStatus = nothing
    next
    set oPing = nothing
 
    Ping = bReturn
end function


sub writeLogFile
	on error resume next

	dim strFile, strTxt
	dim objFSO, objFile

	strTXT = strTXT & "Status" & strStatus & "; Bytes " & strBytes & "; Time(ms) " & strTime & "; TTL(s) " & strTTL & VbCrLf
	strTXT = strTXT & "STATUS: " & cstr(bFailover) & " - " & Now & VbCrLf
	strFile = "c:\Logs\log.txt"

	if (objFSO.driveExists("c:\Logs\")) then
		' folder exists, need to do anything
	else
		' folder doesn't exist, create folder
		objFSO.CreateDirectory("c:\Logs\")
	end if

	set objFSO = CreateObject("Scripting.FileSystemObject")
	set objFile = objFile.OpenTextFile(strFile, ForAppending, true, TristateUseDefault)
	objFile.WriteLine strTXT
	objFile.Close
end sub


sub doPing
	on error resume next

	' part of solution from http://stackoverflow.com/questions/18150241/start-service-with-vbscript
	set wmi = GetObject("winmgmts://./root/cimv2") ' <-- this means the local server
	set service = wmi.Get("Win32_Service.Name='DHCPServer'")

	' IF Ping RETURNS TRUE
	if Ping(strHostPrimary) then
		' strHostPrimary is reachable -- turn off failover service
		if service.Started = true then
			service.StopService
		end if
		writeLogFile
		bFailover = false
	' IF Ping RETURNS FALSE
	else
		' strHostPrimary is unreachable -- turn on failover service
		if service.Started = false then
			service.StartService
		end if
		writeLogFile
		bFailover = true
	end if
end sub


sub doDBTransfer
	on error resume next
	dim leaseTemp

		' if primary is available then run this portion
		if bFailover =  false then
			if bDone = false then
				' if done false then between 8 and 9 try to copy DB
				if Hour(Now()) >= 20 and Hour(Now()) < 21 then
					set objShell = WScript.CreateObject("WScript.Shell") 
					' export dhcp database
					objShell.run "netsh dhcp server" & strHostPrimary & "export c:\dhcp.txt all", true
					' import dhcp database
					objShell.run "netsh dhcp server import c:\dhcp.txt all", true
					' set lowered lease time
					leaseTemp = 60*(leaseMinutes)
					objShell.run "netsh dhcp server scope all optionvalue 51 DWORD " & leaseTemp, true
					' nullify object
					objShell = nothing
					' regardless if successful or not mark the bool as done
					bDone = true
				end if
			else
				' if done true then after 9 reset switch
				if Hour(Now()) >=21 then
					bDone = false
				end if
			end if
		end if

end sub


' =========================


' SCRIPT STARTS HERE -- RUN SCRIPT ON THE FAILOVER SERVER WITH AN ACCOUNT WITH SYSTEM SERVICE ACCESS
' this is the primary DHCP FQDN string variable
strHostPrimary = "host.domain.fqdn"
' this is how many minutes the script will wait until it loops its logic
loopMinutes = 2
' this sets the lease time for the failover server
leaseMinutes = 15

while true
	doPing
	doDBTransfer
	' sleep is in milliseconds, so 60*1000 is one minute
	wscript.sleep((loopMinutes)*60*1000)
wend

Revision: 65329

at November 20, 2013 11:08 by luckygreentiger

Updated Code

' Script created by floyd (luckygreentiger at gmail)
' This should allow a Windows server 2008+ act as a failover
' server for another (primary) DHCP server. The code should work
' but is untested. It was going to be used for work but ultimately
' fell through before it could be used. I am posting it for people
' to use in the hopes someone gets use out of it. If you do use it
' let me know please! This may (possibly) work for 2003+ too. For use
' as-is. No promises to work implied or given. Given freely but
' I am not liable for any damage done with this script.
' 19 November 2013

' If you find errors and want to make corrections please email
' me at the included email address (above). Thank you.

' DECLARE GLOBAL VARIABLES
dim strHTML, strStatus, strBytes, strTime, strTTL, strHostPrimary
dim bFailover, bDone
dim loopMinutes, leaseMinutes
dim mailMessage, mailRelay

bDone = false


' DECLARED FUNCTIONS OF SCRIPT
' function from http://larsmichelsen.com/vbs/quickie-how-to-ping-a-host-in-vbs-i-got-two-ways/
' uses WMI to ping a server string and returns false for failure; and true for success
function Ping(strHostPrimary)
    dim oPing, oRetStatus, bReturn
    set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address='" & strHostPrimary & "'")
 
    for each oRetStatus in oPing
        if IsNull(oRetStatus.StatusCode) or oRetStatus.StatusCode <> 0 then
            bReturn = false
			strStatus = oRetStatus.StatusCode
        else
            bReturn = true
			strBytes = oRetStatus.BufferSize
            strTime = oRetStatus.ResponseTime
            strTTL = oRetStatus.ResponseTimeToLive
        end if
        set oRetStatus = nothing
    next
    set oPing = nothing
 
    Ping = bReturn
end function


sub writeLogFile
	on error resume next

	dim strFile, strTxt
	dim objFSO, objFile

	strTXT = strTXT & "Status" & strStatus & "; Bytes " & strBytes & "; Time(ms) " & strTime & "; TTL(s) " & strTTL & VbCrLf
	strTXT = strTXT & "STATUS: " & cstr(bFailover) & " - " & Now & VbCrLf
	strFile = "c:\Logs\log.txt"

	if (objFSO.driveExists("c:\Logs\")) then
		' folder exists, need to do anything
	else
		' folder doesn't exist, create folder
		objFSO.CreateDirectory("c:\Logs\")
	end if

	set objFSO = CreateObject("Scripting.FileSystemObject")
	set objFile = objFile.OpenTextFile(strFile, ForAppending, true, TristateUseDefault)
	objFile.WriteLine strTXT
	objFile.Close
end sub


sub doPing
	on error resume next

	' part of solution from http://stackoverflow.com/questions/18150241/start-service-with-vbscript
	set wmi = GetObject("winmgmts://./root/cimv2") ' <-- this means the local server
	set service = wmi.Get("Win32_Service.Name='DHCPServer'")

	' IF Ping RETURNS TRUE
	if Ping(strHostPrimary) then
		' strHostPrimary is reachable -- turn off failover service
		if service.Started = true then
			service.StopService
		end if
		writeLogFile
		bFailover = false
	' IF Ping RETURNS FALSE
	else
		' strHostPrimary is unreachable -- turn on failover service
		if service.Started = false then
			service.StartService
		end if
		writeLogFile
		bFailover = true
	end if
end sub


sub doDBTransfer
	on error resume next
	dim leaseTemp

		' if primary is available then run this portion
		if bFailover =  false then
			if bDone = false then
				' if done false then between 8 and 9 try to copy DB
				if Hour(Now()) >= 20 and Hour(Now()) < 21 then
					set objShell = WScript.CreateObject("WScript.Shell") 
					' export dhcp database
					objShell.run "netsh dhcp server" & strHostPrimary & "export c:\dhcp.txt all", true
					' import dhcp database
					objShell.run "netsh dhcp server import c:\dhcp.txt all", true
					' set lowered lease time
					leaseTemp = 60*(leaseMinutes)
					objShell.run "netsh dhcp server scope all optionvalue 51 DWORD " & leaseTemp, true
					' nullify object
					objShell = nothing
					' regardless if successful or not mark the bool as done
					bDone = true
				end if
			else
				' if done true then after 9 reset switch
				if Hour(Now()) >=21 then
					bDone = false
				end if
			end if
		end if

end sub


' =========================


' SCRIPT STARTS HERE -- RUN SCRIPT ON THE FAILOVER SERVER WITH AN ACCOUNT WITH SYSTEM SERVICE ACCESS
' this is the primary DHCP FQDN string variable
strHostPrimary = "host.domain.fqdn"
' this is how many minutes the script will wait until it loops its logic
loopMinutes = 2
' this sets the lease time for the failover server
leaseMinutes = 15

while true
	doPing
	doDBTransfer
	' sleep is in milliseconds, so 60*1000 is one minute
	wscript.sleep((loopMinutes)*60*1000)
wend

Revision: 65328

at November 20, 2013 11:01 by luckygreentiger

Updated Code

' Script created by floyd (luckygreentiger at gmail)
' This should allow a Windows server 2008+ act as a failover
' server for another (primary) DHCP server. The code should work
' but is untested. It was going to be used for work but ultimately
' fell through before it could be used. I am posting it for people
' to use in the hopes someone gets use out of it. If you do use it
' let me know please! This may (possibly) work for 2003+ too. For use
' as-is. No promises to work implied or given. Given freely but
' I am not liable for any damage done with this script.
' 19 November 2013


' DECLARE GLOBAL VARIABLES
dim strHTML, strStatus, strBytes, strTime, strTTL, strHostPrimary
dim bFailover, bDone
dim loopMinutes, leaseMinutes
dim mailMessage, mailRelay

bDone = false


' DECLARED FUNCTIONS OF SCRIPT
' function from http://larsmichelsen.com/vbs/quickie-how-to-ping-a-host-in-vbs-i-got-two-ways/
' uses WMI to ping a server string and returns false for failure; and true for success
function Ping(strHostPrimary)
    dim oPing, oRetStatus, bReturn
    set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address='" & strHostPrimary & "'")
 
    for each oRetStatus in oPing
        if IsNull(oRetStatus.StatusCode) or oRetStatus.StatusCode <> 0 then
            bReturn = false
			strStatus = oRetStatus.StatusCode
        else
            bReturn = true
			strBytes = oRetStatus.BufferSize
            strTime = oRetStatus.ResponseTime
            strTTL = oRetStatus.ResponseTimeToLive
        end if
        set oRetStatus = nothing
    next
    set oPing = nothing
 
    Ping = bReturn
end function


sub writeLogFile
	on error resume next

	dim strFile, strTxt
	dim objFSO, objFile

	strTXT = strTXT & "Status" & strStatus & "; Bytes " & strBytes & "; Time(ms) " & strTime & "; TTL(s) " & strTTL & VbCrLf
	strTXT = strTXT & "STATUS: " & cstr(bFailover) & " - " & Now & VbCrLf
	strFile = "c:\Logs\log.txt"

	if (objFSO.driveExists("c:\Logs\")) then
		' folder exists, need to do anything
	else
		' folder doesn't exist, create folder
		objFSO.CreateDirectory("c:\Logs\")
	end if

	set objFSO = CreateObject("Scripting.FileSystemObject")
	set objFile = objFile.OpenTextFile(strFile, ForAppending, true, TristateUseDefault)
	objFile.WriteLine strTXT
	objFile.Close
end sub


sub doPing
	on error resume next

	' part of solution from http://stackoverflow.com/questions/18150241/start-service-with-vbscript
	set wmi = GetObject("winmgmts://./root/cimv2") ' <-- this means the local server
	set service = wmi.Get("Win32_Service.Name='DHCPServer'")

	' IF Ping RETURNS TRUE
	if Ping(strHostPrimary) then
		' strHostPrimary is reachable -- turn off failover service
		if service.Started = true then
			service.StopService
		end if
		writeLogFile
		bFailover = false
	' IF Ping RETURNS FALSE
	else
		' strHostPrimary is unreachable -- turn on failover service
		if service.Started = false then
			service.StartService
		end if
		writeLogFile
		bFailover = true
	end if
end sub


sub doDBTransfer
	on error resume next
	dim leaseTemp

		' if primary is available then run this portion
		if bFailover =  false then
			if bDone = false then
				' if done false then between 8 and 9 try to copy DB
				if Hour(Now()) >= 20 and Hour(Now()) < 21 then
					set objShell = WScript.CreateObject("WScript.Shell") 
					' export dhcp database
					objShell.run "netsh dhcp server" & strHostPrimary & "export c:\dhcp.txt all", true
					' import dhcp database
					objShell.run "netsh dhcp server import c:\dhcp.txt all", true
					' set lowered lease time
					leaseTemp = 60*(leaseMinutes)
					objShell.run "netsh dhcp server scope all optionvalue 51 DWORD " & leaseTemp, true
					' nullify object
					objShell = nothing
					' regardless if successful or not mark the bool as done
					bDone = true
				end if
			else
				' if done true then after 9 reset switch
				if Hour(Now()) >=21 then
					bDone = false
				end if
			end if
		end if

end sub


' =========================


' SCRIPT STARTS HERE -- RUN SCRIPT ON THE FAILOVER SERVER WITH AN ACCOUNT WITH SYSTEM SERVICE ACCESS
' this is the primary DHCP FQDN string variable
strHostPrimary = "\\server.fqdn"
' this is how many minutes the script will wait until it loops its logic
loopMinutes = 2
' this sets the lease time for the failover server
leaseMinutes = 15

while true
	doPing
	doDBTransfer
	' sleep is in milliseconds, so 60*1000 is one minute
	wscript.sleep((loopMinutes)*60*1000)
wend

Revision: 65327

at November 20, 2013 10:59 by luckygreentiger

Initial Code

' Script created by floyd (luckygreentiger at gmail)
' This should allow a Windows server 2008+ act as a failover
' server for another (primary) DHCP server. The code should work
' but is untested. It was going to be used for work but ultimately
' fell through before it could be used. I am posting it for people
' to use in the hopes someone gets use out of it. If you do use it
' let me know please! This may (possibly) work for 2003+ too. For use
' as-is. No promises to work implied or given. Given freely but
' I am not liable for any damage done with this script.
' 19 November 2013


' DECLARE GLOBAL VARIABLES
dim strHTML, strStatus, strBytes, strTime, strTTL, strHostPrimary
dim bFailover, bDone
dim loopMinutes, leaseMinutes
dim mailMessage, mailRelay

bDone = false


' DECLARED FUNCTIONS OF SCRIPT
' function from http://larsmichelsen.com/vbs/quickie-how-to-ping-a-host-in-vbs-i-got-two-ways/
' uses WMI to ping a server string and returns false for failure; and true for success
function Ping(strHostPrimary)
    dim oPing, oRetStatus, bReturn
    set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address='" & strHostPrimary & "'")
 
    for each oRetStatus in oPing
        if IsNull(oRetStatus.StatusCode) or oRetStatus.StatusCode <> 0 then
            bReturn = false
			strStatus = oRetStatus.StatusCode
        else
            bReturn = true
			strBytes = oRetStatus.BufferSize
            strTime = oRetStatus.ResponseTime
            strTTL = oRetStatus.ResponseTimeToLive
        end if
        set oRetStatus = nothing
    next
    set oPing = nothing
 
    Ping = bReturn
end function


sub writeLogFile
	on error resume next

	dim strFile, strTxt
	dim objFSO, objFile

	strTXT = strTXT & "Status" & strStatus & "; Bytes " & strBytes & "; Time(ms) " & strTime & "; TTL(s) " & strTTL & VbCrLf
	strTXT = strTXT & "STATUS: " & cstr(bFailover) & " - " & Now & VbCrLf
	strFile = "c:\Logs\log.txt"

	if (objFSO.driveExists("c:\Logs\)) then
		' folder exists, need to do anything
	else
		' folder doesn't exist, create folder
		objFSO.CreateDirectory("c:\Logs\")
	end if

	set objFSO = CreateObject("Scripting.FileSystemObject")
	set objFile = objFile.OpenTextFile(strFile, ForAppending, true, TristateUseDefault)
	objFile.WriteLine strTXT
	objFile.Close
end sub


sub doPing
	on error resume next

	' part of solution from http://stackoverflow.com/questions/18150241/start-service-with-vbscript
	set wmi = GetObject("winmgmts://./root/cimv2") ' <-- this means the local server
	set service = wmi.Get("Win32_Service.Name='DHCPServer'")

	' IF Ping RETURNS TRUE
	if Ping(strHostPrimary) then
		' strHostPrimary is reachable -- turn off failover service
		if service.Started = true then
			service.StopService
		end if
		writeLogFile
		bFailover = false
	' IF Ping RETURNS FALSE
	else
		' strHostPrimary is unreachable -- turn on failover service
		if service.Started = false then
			service.StartService
		end if
		writeLogFile
		bFailover = true
	end if
end sub


sub doDBTransfer
	on error resume next
	dim leaseTemp

		' if primary is available then run this portion
		if bFailover =  false then
			if bDone = false then
				' if done false then between 8 and 9 try to copy DB
				if Hour(Now()) >= 20 and Hour(Now()) < 21 then
					set objShell = WScript.CreateObject("WScript.Shell") 
					' export dhcp database
					objShell.run "netsh dhcp server" & strHostPrimary & "export c:\dhcp.txt all", true
					' import dhcp database
					objShell.run "netsh dhcp server import c:\dhcp.txt all", true
					' set lowered lease time
					leaseTemp = 60*(leaseMinutes)
					objShell.run "netsh dhcp server scope all optionvalue 51 DWORD " & leaseTemp, true
					' nullify object
					objShell = nothing
					' regardless if successful or not mark the bool as done
					bDone = true
				end if
			else
				' if done true then after 9 reset switch
				if Hour(Now()) >=21 then
					bDone = false
				end if
			end if
		end if

end sub


' =========================


' SCRIPT STARTS HERE -- RUN SCRIPT ON THE FAILOVER SERVER WITH AN ACCOUNT WITH SYSTEM SERVICE ACCESS
' this is the primary DHCP FQDN string variable
strHostPrimary = "\\server.fqdn"
' this is how many minutes the script will wait until it loops its logic
loopMinutes = 2
' this sets the lease time for the failover server
leaseMinutes = 15

while true
	doPing
	doDBTransfer
	' sleep is in milliseconds, so 60*1000 is one minute
	wscript.sleep((loopMinutes)*60*1000)
wend

Initial URL

Initial Description

VBscript that runs on a backup DHCP server that would start the DHCP service once the primary DHCP server fails to respond. It was a work project that failed to materialize. It's untested but it should work.

Initial Title

DHCP failover script

Initial Tags

Initial Language

Visual Basic

Choose a language for easy browsing: