WAN IP Poster VBScript

WAN IP Posting VBScript
(Another donateWare script from MRE Software)

If you are running a webcam or other server on a home computer that needs to be accessed from the Internet but you don't have a static IP address then you must keep any links to the server that appear on your website updated. One method to do this is by subscribing to a dynamic dns service. Another method is to use software on your local system that checks your WAN IP address and updates your web page via FTP.

The vbscript below will do the job silently by running as a process of the Windows Script Host on any WindowsXP or later system. I wrote this script using a lot of help from others on the Internet and have referenced their work within the script. A downloadable .zip file is linked below the script window that includes a complete package of files and instructions of how to use this.

ENJOY!

'This script retrieves the WAN IP address and outputs a file both locally and via FTP. 'The local "template.htm" file uses the tag %%IP%% wherever the WAN IP needs to be placed. 'The "output.htm" file is saved locally and uploaded to a web address. 'The user will need to edit the block below these comments to reflect your filenames and addresses. '--- 'Written by Emery Wooten - www.mresoftware.com - USE AT YOUR OWN RISK 'Parts of this script may fall under various software licenses. 'Please READ and acknowledge the original authors of the functions used below. Option Explicit '----User must edit these parameters for their setup--------------------------------------------------------- dim CheckSec : CheckSec = 91 'number of seconds between checks dim inputFile : inputFile = "template.htm" 'your template filename dim outputFile : outputFile = "output.htm" 'your output filename dim sSite : sSite = "yourftpsite.com" 'your FTP server - do not include ftp:// dim sUsername : sUsername = "username" 'your FTP user name dim sPassword : sPassword = "password" 'your FTP password dim sRemotePath : sRemotePath = "public_html/yourfolder" 'path to the FTP server destination folder '----End of user editable parameters-------------------------------------------------------------------------- dim strURL : strURL = "http://icanhazip.com/" 'alternate choices http://myip.dnsomatic.com/ or http://ifconfig.me/ip dim objRequest, strMsg dIM newIP : newIP = "0.0.0.0" dIM oldIP : oldIP = "1.2.3.4" dim FTPresult dim i : i=0 dim j : j=1 '====main code below================================================================================= Do While i<>10 'infinite loop newIP = MyIP_WinHTTP(strURL) 'get the WAN IP If newIP = "0.0.0.0" Then newIP = OldIP 'check for valid IP address. if not, keep old IP for this loop If newIP <> oldIP Then 'only update files if IP has changed since last check. 'WScript.Echo newIP 'for dubugging TranslateFile newIP,inputFile,outputFile FTPresult = FTPUpload (sSite,sUsername,sPassword,outputFile,sRemotePath) 'WScript.Echo FTPresult 'for debugging End If oldIP = newIP WScript.Sleep CheckSec * 1000 j = j+1 If j * CheckSec >= 7200 Then 'force an upload about every two hours just for good measure j = 1 oldIP = "0.0.0.0" End If Loop 'To make this a one-shot script, comment out the "Do While" and "Loop" statements above then save under a new name. '====functions below================================================================================== Function MyIP_WinHTTP(strURL) ' Adapted from a script Written by Rob van der Woude - http://www.robvanderwoude.com MyIP_WinHTTP = "0.0.0.0" 'Return value in case the IP address could not be retrieved 'Retrieve the URL's text dim objHTTP : Set objHTTP = CreateObject( "WinHttp.WinHttpRequest.5.1" ) objHTTP.SetTimeouts 1000, 1000, 1000, 1000 objHTTP.Open "GET", strURL On Error Resume Next objHTTP.Send If Err.Number = 0 Then If objHttp.Status = "200" Then MyIP_WinHTTP = objHTTP.ResponseText End If Set objHTTP = Nothing End Function '========================================================= Function TranslateFile(newIP,inputFile,outputFile) Dim oFSO : Set oFSO = CreateObject("Scripting.FileSystemObject") 'Read the template input file Dim f : Set f = oFSO.OpenTextFile(inputFile, 1) Dim sData : sData = f.ReadAll f.close sData = Replace(sData,"%%IP%%",newIP) 'replace the tags with the IP value 'Write the translated output file Set f = oFSO.CreateTextFile(outputFile, 2) f.Write sData f.close Set oFSO = Nothing End Function '========================================================= Function FTPUpload(sSite, sUsername, sPassword, sLocalFile, sRemotePath) 'This script is provided under the Creative Commons license located 'at http://creativecommons.org/licenses/by-nc/2.5/ . It may not 'be used for commercial purposes with out the expressed written consent 'of NateRice.com Const OpenAsDefault = -2 Const FailIfNotExist = 0 Const ForReading = 1 Const ForWriting = 2 dim oFTPScriptFSO : Set oFTPScriptFSO = CreateObject("Scripting.FileSystemObject") dim oFTPScriptShell : Set oFTPScriptShell = CreateObject("WScript.Shell") sRemotePath = Trim(sRemotePath) sLocalFile = Trim(sLocalFile) '----------Path Checks--------- 'Here we willcheck the path, if it contains 'spaces then we need to add quotes to ensure 'it parses correctly. If InStr(sRemotePath, " ") > 0 Then If Left(sRemotePath, 1) <> """" And Right(sRemotePath, 1) <> """" Then sRemotePath = """" & sRemotePath & """" End If End If If InStr(sLocalFile, " ") > 0 Then If Left(sLocalFile, 1) <> """" And Right(sLocalFile, 1) <> """" Then sLocalFile = """" & sLocalFile & """" End If End If 'Check to ensure that a remote path was 'passed. If it's blank then pass a "\" If Len(sRemotePath) = 0 Then 'Please note that no premptive checking of the 'remote path is done. If it does not exist for some 'reason. Unexpected results may occur. sRemotePath = "\" End If 'Check the local path and file to ensure 'that either the a file that exists was 'passed or a wildcard was passed. If InStr(sLocalFile, "*") Then If InStr(sLocalFile, " ") Then FTPUpload = "Error: Wildcard uploads do not work if the path contains a " & _ "space." & vbCRLF FTPUpload = FTPUpload & "This is a limitation of the Microsoft FTP client." Exit Function End If ElseIf Len(sLocalFile) = 0 Or Not oFTPScriptFSO.FileExists(sLocalFile) Then 'nothing to upload FTPUpload = "Error: File Not Found." Exit Function End If '--------END Path Checks--------- 'build input file for ftp command dim sFTPScript : sFTPScript = sFTPScript & "USER " & sUsername & vbCRLF sFTPScript = sFTPScript & sPassword & vbCRLF sFTPScript = sFTPScript & "cd " & sRemotePath & vbCRLF sFTPScript = sFTPScript & "binary" & vbCRLF sFTPScript = sFTPScript & "prompt n" & vbCRLF sFTPScript = sFTPScript & "put " & sLocalFile & vbCRLF sFTPScript = sFTPScript & "quit" & vbCRLF & "quit" & vbCRLF & "quit" & vbCRLF dim sFTPTemp : sFTPTemp = oFTPScriptShell.ExpandEnvironmentStrings("%TEMP%") dim sFTPTempFile : sFTPTempFile = sFTPTemp & "\" & oFTPScriptFSO.GetTempName dim sFTPResults : sFTPResults = sFTPTemp & "\" & oFTPScriptFSO.GetTempName 'Write the input file for the ftp command 'to a temporary file. dim fFTPScript : Set fFTPScript = oFTPScriptFSO.CreateTextFile(sFTPTempFile, True) fFTPScript.WriteLine(sFTPScript) fFTPScript.Close Set fFTPScript = Nothing oFTPScriptShell.Run "%comspec% /c FTP -n -s:" & sFTPTempFile & " " & sSite & _ " > " & sFTPResults, 0, TRUE Wscript.Sleep 1000 'Check results of transfer. dim fFTPResults : Set fFTPResults = oFTPScriptFSO.OpenTextFile(sFTPResults, ForReading, _ FailIfNotExist, OpenAsDefault) dim sResults : sResults = fFTPResults.ReadAll fFTPResults.Close oFTPScriptFSO.DeleteFile(sFTPTempFile) oFTPScriptFSO.DeleteFile (sFTPResults) If InStr(sResults, "226") > 0 Then FTPUpload = "SUCCESS" & vbCRLF & sResults Else FTPUpload = "FTP FAILED" & vbCRLF & sResults End If Set oFTPScriptFSO = Nothing Set oFTPScriptShell = Nothing End Function

To download a complete package of files including the readme.txt and bonus scripts

If you find this code of value, donate a little to the cause. Think of the time you just saved!

USE AT YOUR OWN RISK!

Questions / Comments? Email me.