Проверка внешнего IP и смена dynamic IP для модема Westell 6100  
Internet APIs, regular expressions, Router Web interface, WebBrowser Control  


Код использует wininet.dll APIs  regular expressions для проверки Public IP.  В случае, если один из "What is my IP" сайтов отключен, программа пытается достучаться до следующего. В случае, если wininet.dll API возвращает ошибку, программа преобразует код ошибки в текст.

WebBrowser control используется для имитации нажима клавиш "disconnect/reconnect" пользователем.  После нажатия клавиши программа ждет, пока не получит ответ на event DocumentComplete, а затем пока статус Web документа не становится "complete".

Время на запрос изменения IP получено экспвриментально.  Замечено, что иногда модем реконнектится "сам по себе", не получив новый IP.  В связи с этим в процессе ожидания вводена дополнительная проверка на статус в документе (innertext).

Программа может быть вызвана из .bat файла.  Комманда start /wait (в окне MS DOS) висит и ожидает завершония процесса.

Если есть вопросы, с удовольствием отвечу


Код:


In project references:  
Microsoft HTML Object Library - C:winntsystem32mshtml.tlb  
MIcrosoft VB Script Regular expressions 5.5 - C:winntsystem32vbscript.dll3  

On form - WebBrowser Control name - brwProxy  
Code in module:  

Option Explicit  

Public Sub Main()  
frmRouter.Show  
frmRouter.ChangeIP  
Unload frmRouter  

End Sub  

code in form:  

Option Explicit  
Dim bStatus As Boolean  

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000 ' don't write this item to the cache  
Private Const INTERNET_FLAG_RELOAD = &H80000000  
Private Const INTERNET_FLAG_PRAGMA_NOCACHE = &H100  
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0  
Private Const SCUSERAGENT = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"  

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _  
(ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _  
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long  
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _  
(ByVal hInternetSession As Long, ByVal sURL As String, ByVal sHeaders As String, _  
ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long  
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, _  
ByVal lpBuffer As String, ByVal dwNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long) _  
As Boolean  
Private Declare Function InternetCloseHandle Lib "wininet.dll" _  
(ByVal hInet As Long) As Integer  

Private Sub brwProxy_DocumentComplete(ByVal pDisp As Object, URL As Variant)  
bStatus = True  
End Sub  

Private Sub WaitForBrowser(Link As String)  
'2 - navNoHistory  
bStatus = False  
brwProxy.Navigate2 Link, 2  
Do While bStatus = False  
DoEvents  
Loop  
Do While brwProxy.Document.ReadyState <> "complete"  
DoEvents  
Loop  

End Sub  

Private Sub WaitForModemStatus(Status As Integer, HTMLDocFR As HTMLDocument)  

'Disconnect - 2  
'connect - 1  
bStatus = False  
HTMLDocFR.PPPAction.PPPRequest.Value = Status  
HTMLDocFR.PPPAction.currentCnIndex.Value = 0  
HTMLDocFR.PPPAction.submit  

Do While bStatus = False  
DoEvents  
Loop  
Do While brwProxy.Document.ReadyState <> "complete"  
DoEvents  
Loop  

End Sub  

Private Sub WaitInterval(Seconds As Integer, _  
Release As Boolean, HTMLDocFR As HTMLDocument, CheckConnect As Boolean)  
Dim Date1 As Date  
Dim DateTemp As Date  
Dim intDiff As Integer  
Date1 = Now  
DateTemp = DateAdd("s", Seconds, Date1)  
Do While Now < DateTemp  
DoEvents  
intDiff = DateDiff("s", Now, DateTemp)  
If CheckConnect Then  
If intDiff < Seconds And intDiff Mod 10 = 0 Then  
If VerifyDisconnect(HTMLDocFR) Then  
Exit Do  
End If  
End If  
End If  

Loop  
End Sub  

Public Sub ChangeIP()  
Dim strTemp As String  
Dim HTMLDocFR As MSHTML.HTMLDocument  
Dim HTMLDoc As MSHTML.HTMLDocument  
Dim strOldIP As String  
Dim strNewIP As String  

strTemp = "http://192.168.1.1"  
WaitForBrowser strTemp  
Set HTMLDoc = brwProxy.Document  
Set HTMLDocFR = HTMLDoc.frames(0).Document  
strOldIP = GetPublicIP  
strNewIP = strOldIP  
Do While strOldIP = strNewIP  
'Disconnect  
WaitForModemStatus 2, HTMLDocFR  
WaitInterval 55, True, HTMLDocFR, True  
If Not VerifyDisconnect(HTMLDocFR) Then  
'connect  
WaitForModemStatus 1, HTMLDocFR  
WaitInterval 5, True, HTMLDocFR, False  
End If  
strNewIP = GetPublicIP  
Loop  
End Sub  

Private Function VerifyDisconnect(HTMLDocFR As HTMLDocument) As Boolean  
On Error GoTo Error_Handler  
VerifyDisconnect = False  
If InStr(HTMLDocFR.body.innerText, "Auto RegistrationUP") > 0 Then  
VerifyDisconnect = True  

End If  
Exit Function  

Error_Handler:  

End Function  

Public Function GetPublicIP() As String  
Dim WebSites(6) As String  
Dim strPublicIP As String  
Dim I As Integer  

strPublicIP = ""  
WebSites(0) = "http://vbnet.mvps.org/resources/tools/getpublicip.shtml"  
WebSites(1) = "http://whatismyip.com"  
WebSites(2) = "http://www.whatismyip.org"  
WebSites(3) = "http://www.showmyip.com"  
WebSites(4) = "http://www.auditmypc.com/whats-my-ip.asp"  
WebSites(5) = "http://myip.dk"  
WebSites(6) = "http://formyip.com"  
I = 0  
Do While Len(Trim(strPublicIP)) = 0  
strPublicIP = GetPublicIPSingle(WebSites(I))  
I = I + 1  
If I > 6 Then I = 0  
Loop  
GetPublicIP = strPublicIP  
End Function  

Private Function GetPublicIPSingle(WebSite As String) As String  
Dim strRet As String  

strRet = OpenCurUrl(WebSite)  
GetPublicIPSingle = ""  
With New RegExp  
.MultiLine = True  
.Pattern = "(d{1,4}.d{1,4}.d{1,4}.d{1,4})"  
If .Test(strRet) Then  
GetPublicIPSingle = .Execute(strRet).Item(0).SubMatches(0)  
End If  
End With  
End Function  
Private Function TranslateErrorCode(ByVal lErrorCode As Long) As String  
Select Case lErrorCode  
Case 0  
Case 12001: TranslateErrorCode = "No more handles could be generated at this time"  
Case 12002: TranslateErrorCode = "The request has timed out."  
Case 12003: TranslateErrorCode = "An extended error was returned from the server."  
Case 12004: TranslateErrorCode = "An internal error has occurred."  
Case 12005: TranslateErrorCode = "The URL is invalid."  
Case 12006: TranslateErrorCode = "The URL scheme could not be recognized, or is not supported."  
Case 12007: TranslateErrorCode = "The server name could not be resolved."  
Case 12008: TranslateErrorCode = "The requested protocol could not be located."  
Case 12009: TranslateErrorCode = "A request to InternetQueryOption or InternetSetOption specified an invalid option value."  
Case 12010: TranslateErrorCode = "The length of an option supplied to InternetQueryOption or InternetSetOption is incorrect for the type of option specified."  
Case 12011: TranslateErrorCode = "The request option can not be set, only queried. "  
Case 12012: TranslateErrorCode = "The Win32 Internet support is being shutdown or unloaded."  
Case 12013: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied user name is incorrect."  
Case 12014: TranslateErrorCode = "The request to connect and login to an FTP server could not be completed because the supplied password is incorrect. "  
Case 12015: TranslateErrorCode = "The request to connect to and login to an FTP server failed."  
Case 12016: TranslateErrorCode = "The requested operation is invalid. "  
Case 12017: TranslateErrorCode = "The operation was canceled, usually because the handle on which the request was operating was closed before the operation completed."  
Case 12018: TranslateErrorCode = "The type of handle supplied is incorrect for this operation."  
Case 12019: TranslateErrorCode = "The requested operation can not be carried out because the handle supplied is not in the correct state."  
Case 12020: TranslateErrorCode = "The request can not be made via a proxy."  
Case 12021: TranslateErrorCode = "A required registry value could not be located. "  
Case 12022: TranslateErrorCode = "A required registry value was located but is an incorrect type or has an invalid value."  
Case 12023: TranslateErrorCode = "Direct network access cannot be made at this time. "  
Case 12024: TranslateErrorCode = "An asynchronous request could not be made because a zero context value was supplied."  
Case 12025: TranslateErrorCode = "An asynchronous request could not be made because a callback function has not been set."  
Case 12026: TranslateErrorCode = "The required operation could not be completed because one or more requests are pending."  
Case 12027: TranslateErrorCode = "The format of the request is invalid."  
Case 12028: TranslateErrorCode = "The requested item could not be located."  
Case 12029: TranslateErrorCode = "The attempt to connect to the server failed."  
Case 12030: TranslateErrorCode = "The connection with the server has been terminated."  
Case 12031: TranslateErrorCode = "The connection with the server has been reset."  
Case 12036: TranslateErrorCode = "The request failed because the handle already exists."  
Case Else: TranslateErrorCode = "Error details not available."  
End Select  
End Function  

Private Function OpenCurUrl(ByVal sURL As String) As String  
Dim hInet As Long 'inet handle  
Dim hFile As Long 'url handle  
Dim lFlags As Long  
'read file vars  
On Error GoTo ErrHandler  
Dim bDoLoop As Boolean  
Dim bRet As Boolean  
Dim sReadBuffer As String * 1024  
Dim sBuffer As String  
Dim lNumberOfBytesRead As Long  
lFlags = INTERNET_FLAG_NO_CACHE_WRITE Or _  
INTERNET_FLAG_RELOAD Or _  
INTERNET_FLAG_PRAGMA_NOCACHE  

'connect  
hInet = InternetOpen(SCUSERAGENT, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)  
If hInet <> 0 Then  
hFile = InternetOpenUrl(hInet, sURL, vbNullString, 0, lFlags, 0)  
If CBool(hFile) Then  
'read file  
bDoLoop = True  
While bDoLoop  
sReadBuffer = vbNullString  
bRet = InternetReadFile(hFile, sReadBuffer, 1024, lNumberOfBytesRead)  
sBuffer = sBuffer & Left(sReadBuffer, lNumberOfBytesRead)  
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False  
Wend  
OpenCurUrl = sBuffer  
Else  
OpenCurUrl = TranslateErrorCode(Err.LastDllError)  
End If  
Else  
OpenCurUrl = "Failed to initialize INET"  
End If  
ErrHandler:  
If hFile <> 0 Then InternetCloseHandle hFile  
If hInet <> 0 Then InternetCloseHandle hInet  

If Err.Number > 0 Then  

OpenCurUrl = "Error " & Err.Number & ": " & Err.Description  
End If  
End Function  

bat file:  

@echo off  
start /wait C:VBprojectsroutervbroutervb.exe  
ping 127.0.0.1 -n 1 >nul