UriF
Advanced Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору Проверка внешнего 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) висит и ожидает завершония процесса. Можно задать статус визибл/не визибл в .ini файле Rou.ini Если есть вопросы, с удовольствием отвечу Код: . ini file - Rou.ini [General] Visible=1 InitTimeOut=210 Increment=30 ConnectionName=verizon high speed In project references: MIcrosoft VB Script Regular expressions 5.5 - C:\winnt\system32\vbscript.dll\3 On form - WebBrowser Control name - brwProxy for testing purposes are used labels (Label1, Label2, Label3, Label4), i.e. old/new IP comparisons, time out, seconds' counter Code in module: Option Explicit Public OldIP As String Public NewIP As String Public gInitTimeOut As Integer Public gintIncrement As Integer Public gsConnection As String Dim intVisible As Integer Private Declare Function GetPrivateProfileStringA Lib "kernel32" (ByVal lpApplicationName As String, _ ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer Public Sub Main() Dim TimeStart As Date TimeStart = Now ReadINI Load frmRouter If intVisible = 1 Then frmRouter.Show End If OldIP = frmRouter.GetPublicIP frmRouter.ChangeIP NewIP = frmRouter.GetPublicIP Unload frmRouter 'MsgBox DateDiff("s", TimeStart, Now) & _ vbCrLf & OldIP & _ vbCrLf & NewIP End Sub Private Sub ReadINI() Dim AppIni As String Dim AppPath As String Dim temp As String Dim Ret As Integer AppIni = Mid$(App.EXEName, 1, 3) & ".ini" AppPath = App.Path If Right$(AppPath, 1) <> "\" Then AppPath = AppPath & "\" AppPath = AppPath & AppIni temp = Space(255) Ret = GetPrivateProfileStringA("General", "Visible", "", temp, Len(temp), AppPath) If Ret > 0 Then intVisible = Left$(temp, Ret) Else intVisible = 1 End If Ret = GetPrivateProfileStringA("General", "InitTimeOut", "", temp, Len(temp), AppPath) If Ret > 0 Then gInitTimeOut = Left$(temp, Ret) Else gInitTimeOut = 90 End If Ret = GetPrivateProfileStringA("General", "Increment", "", temp, Len(temp), AppPath) If Ret > 0 Then gintIncrement = Left$(temp, Ret) Else gintIncrement = 15 End If Ret = GetPrivateProfileStringA("General", "ConnectionName", "", temp, Len(temp), AppPath) If Ret > 0 Then gsConnection = Left$(temp, Ret) Else gsConnection = "verizon high speed" End If 'WriteToLog 50 End Sub Public Sub WriteToLog(PassString As String) Dim strFileName As String Dim strTemp As String Dim iFile As Integer strFileName = Mid$(App.EXEName, 1, 3) & ".log" strTemp = App.Path If Right$(strTemp, 1) <> "\" Then strTemp = strTemp & "\" strFileName = strTemp & strFileName iFile = FreeFile Open strFileName For Append As iFile Print #iFile, PassString & vbCrLf Close iFile End Sub code in form: Option Explicit 'http://vbnet.mvps.org/index.html?code/internet/getpublicip.htm Dim bStatus As Boolean Dim mintReminder As Integer Dim ErrConnect As Long 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 INTERNET_FLAG_KEEP_CONNECTION = &H400000 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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub WaitForBrowser(Link As String) '2 - navNoHistory bStatus = False brwProxy.Navigate2 Link, 2 Do While bStatus = False DoEvents Loop MySleep 1, True Do While brwProxy.Document.ReadyState <> "complete" DoEvents Loop End Sub Private Sub WaitForModemStatus(Status As Integer) 'Disconnect - 2 'Connect - 1 On Error GoTo Error_Handler Dim bContinue As Boolean ChangeRouterStatus Status bContinue = True Do While bContinue If VerifyStatus(Status) Then bContinue = False Else MySleep 1 End If Loop On Error GoTo 0 Exit Sub Error_Handler: If Err.Number = 91 Then MySleep 5 End If Err.Clear Resume End Sub Private Sub WaitInterval(Seconds As Integer, _ Release As Boolean, CheckConnect As Boolean) Dim Date1 As Date Dim DateTemp As Date Dim intDiff As Integer mintReminder = 0 Date1 = Now Do While brwProxy.Document.ReadyState <> "complete" DoEvents Loop On Error GoTo Error_Handler DateTemp = DateAdd("s", Seconds, Date1) Do While Now < DateTemp DoEvents MySleep 1, True DoEvents intDiff = DateDiff("s", Now, DateTemp) Label4.Caption = intDiff mintReminder = intDiff If CheckConnect Then If intDiff < Seconds And intDiff Mod 10 = 0 Then If VerifyStatus(1) Then Exit Do End If End If End If Loop On Error GoTo 0 Exit Sub Error_Handler: If Err.Number = 91 Then MySleep 5 End If Err.Clear Resume End Sub Public Sub ChangeIP() Dim strTemp As String Dim Date1 As Date Dim strOldIP As String Dim strNewIP As String Dim initTimeOut As Integer Dim incrementTimeOut As Integer Dim bIncrement As Boolean On Error GoTo Error_Handler mintReminder = 0 strOldIP = GetPublicIP strNewIP = strOldIP Label1.Caption = strOldIP initTimeOut = gInitTimeOut Label2.Caption = strNewIP incrementTimeOut = gintIncrement bIncrement = True Do While strOldIP = strNewIP 'Disconnect WaitForModemStatus 2 Label3.Caption = initTimeOut Date1 = Now Date1 = DateAdd("s", initTimeOut, Date1) WaitInterval initTimeOut, True, True If mintReminder > 10 Then bIncrement = False End If If bIncrement Then initTimeOut = initTimeOut + incrementTimeOut incrementTimeOut = CInt(incrementTimeOut * 1.5) End If bIncrement = True If VerifyStatus(2) Then 'connect WaitForModemStatus 1 WaitInterval 5, True, False Else bIncrement = False End If strNewIP = GetPublicIP Label2.Caption = strNewIP Loop WriteToLog CStr(initTimeOut) On Error GoTo 0 Exit Sub Error_Handler: If Err.Number = 91 Then MySleep 5 End If Err.Clear Resume End Sub Public Function GetPublicIP() As String Dim WebSites(6) As String Dim strPublicIP As String Dim I As Integer ' if disconnected from internet exit function If VerifyStatus(2) Then GetPublicIP = "" Exit Function End If 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)) If ErrConnect <> 0 Then Exit Do End If 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 ErrConnect = lErrorCode 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 ErrConnect = 0 '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" ErrConnect = -1 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 Private Sub brwProxy_DocumentComplete(ByVal pDisp As Object, url As Variant) bStatus = True End Sub Private Sub Form_Load() Dim strTemp As String strTemp = "http://192.168.1.1" WaitForBrowser strTemp End Sub Private Sub MySleep(Seconds As Integer, Optional UseSleep As Boolean = False) Dim Date1 As Date Dim DateTemp As Date Dim intDiff As Integer ' Dim I As Long Date1 = Now DateTemp = DateAdd("s", Seconds, Date1) Do While Now < DateTemp DoEvents If UseSleep Then Sleep 1000 DoEvents End If Loop End Sub Private Function VerifyStatus(Status As Integer) As Boolean On Error GoTo Error_Handler Dim strTemp As String Dim strStatusText As String Dim bContinue As Boolean VerifyStatus = False 'Disconnect - 2 'Connect - 1 On Error GoTo Error_Handler Do While brwProxy.Document.ReadyState <> "complete" DoEvents Loop Select Case Status Case 2 strStatusText = gsConnection & "DOWN" Case 1 strStatusText = gsConnection & "UP" End Select DoEvents strTemp = brwProxy.Document.frames(0).Document.body.innerText If InStr(strTemp, strStatusText) > 0 Then VerifyStatus = True End If On Error GoTo 0 Exit Function Error_Handler: If Err.Number = 91 Then MySleep 5 End If Err.Clear Resume End Function Private Sub ChangeRouterStatus(Status As Integer) On Error GoTo Error_Handler Dim strTemp As String Dim bContinue As Boolean Dim strStatusText As String 'Disconnect - 2 'Connect - 1 bStatus = False With brwProxy.Document.frames(0).Document strTemp = .body.innerText .PPPAction.PPPRequest.Value = Status .PPPAction.currentCnIndex.Value = 0 .PPPAction.submit End With Do While bStatus = False DoEvents Loop MySleep 10, True DoEvents Do While brwProxy.Document.ReadyState <> "complete" DoEvents Loop On Error GoTo 0 Exit Sub Error_Handler: If Err.Number = 91 Then MySleep 5 End If Err.Clear Resume End Sub bat file: @echo off start /wait C:\VBprojects\routervb\routervb.exe ping 127.0.0.1 -n 1 >nul |
и к чему это здесь? | Всего записей: 816 | Зарегистр. 14-06-2004 | Отправлено: 21:19 14-05-2007 | Исправлено: UriF, 07:22 24-04-2008 |
|