Visual Basic 6: Проверка Public IP/смена dynamic IP - [5] :: Прикладное программирование

Модуль #1 - IPAddress

Код:

Option Explicit
Private Declare Function InternetOpen Lib "wininet" 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 InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long

'Purpose : Retreview text from a web site
'Inputs : sURL The URL and file name to extract the text from
' [lBufferSize] The number of characters to extract.
' If value is -1 the reads the whole page.
'Outputs : The text found on the web site
'Notes : NOT SUITABLE FOR ACCESSING THE INTERNET THROUGH A PROXY SERVER

Private Function InternetGetText(sURL As String, Optional lBufferSize As Long = -1) As String
Dim lhOpen As Long, lhFile As Long, sBuffer As String, lRet As Long
Const clBufferIncrement As Long = 2000
Const scUserAgent = "VBUsers"
Const INTERNET_OPEN_TYPE_PRECONFIG = 0, INTERNET_FLAG_EXISTING_CONNECT = &H20000000
Const INTERNET_OPEN_TYPE_DIRECT = 1, INTERNET_OPEN_TYPE_PROXY = 3
Const INTERNET_FLAG_RELOAD = &H80000000

If lBufferSize = -1 Then
'Create an arbitary buffer to read the whole file in parts
sBuffer = String$(clBufferIncrement, Chr$(0))
Else
'Create a specified buffer size
sBuffer = String$(lBufferSize, Chr$(0))
End If
'Create an internet connection
lhOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
'Open the url
lhFile = InternetOpenUrl(lhOpen, sURL, vbNullString, ByVal 0&, INTERNET_FLAG_RELOAD, ByVal 0&)
If lhFile = 0 Then
'Try using proxy
InternetCloseHandle lhFile
InternetCloseHandle lhOpen
'Create an internet connection
lhOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'Open the url
lhFile = InternetOpenUrl(lhOpen, sURL, vbNullString, ByVal 0&, INTERNET_FLAG_EXISTING_CONNECT, ByVal 0&)
End If
If lBufferSize = -1 And lhFile <> 0 Then
'Read the whole page
Do
InternetReadFile lhFile, sBuffer, clBufferIncrement, lRet
InternetGetText = InternetGetText & Left$(sBuffer, lRet)
Loop While lRet = clBufferIncrement
Else
'Read the specified number of bytes from the file
InternetReadFile lhFile, sBuffer, lBufferSize, lRet
InternetGetText = InternetGetText & Left$(sBuffer, lRet)
End If
'clean up
InternetCloseHandle lhFile
InternetCloseHandle lhOpen
End Function

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

strRet = InternetGetText(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

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

Модуль 2 -Global

Код:

Option Explicit
Public UserName As String
Public Password As String
Public gInitTimeOut As Integer
Public gintIncrement As Integer
Dim dStartMainTime As Date
Public gintMaxTimeOut As Integer

Dim dEndMainTime As Date
Public OldIP As String
Public NewIP As String

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
Dim intVisible As Integer

Public Sub InitializeParameters()
GetLoginInfo
ReadINI
End Sub

Private Sub GetLoginInfo()
UserName = "<UserName>"
Password = "<Password>"
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 = 300
End If
Ret = GetPrivateProfileStringA("General", "Increment", "", temp, Len(temp), AppPath)
If Ret > 0 Then
gintIncrement = Left$(temp, Ret)
Else
gintIncrement = 30
End If
Ret = GetPrivateProfileStringA("General", "StartMaintTime", "", temp, Len(temp), AppPath)
If Ret > 0 Then
dStartMainTime = Left$(temp, Ret)
Else
dStartMainTime = "3:00:00 AM"
End If

Ret = GetPrivateProfileStringA("General", "EndMaintTime", "", temp, Len(temp), AppPath)
If Ret > 0 Then
dEndMainTime = Left$(temp, Ret)
Else
dEndMainTime = "5:00:00 AM"
End If
If Time > dStartMainTime And Time < dEndMainTime Then
gInitTimeOut = 1.5 * gInitTimeOut
gintIncrement = 2 * gintIncrement
End If
Ret = GetPrivateProfileStringA("General", "MaxTimeOut", "", temp, Len(temp), AppPath)
If Ret > 0 Then
gintMaxTimeOut = Left$(temp, Ret)
Else
gintMaxTimeOut = 0
End If

End Sub

Public Sub Main()
WriteToLog ("Start Reconnect")
OldIP = GetPublicIP
WriteToLog (OldIP)
InitializeParameters
Load frmRouter
If intVisible = 1 Then
frmRouter.Show
End If
frmRouter.ChangeIP
NewIP = GetPublicIP
Unload frmRouter
WriteToLog ("End Reconnect")
WriteToLog (NewIP)
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 & " " & CStr(Time) & vbCrLf
Close iFile
End Sub

На форме добавляем

Код:

WebBrowser Control (brwIPChanger) (Microsoft Internet Controls)

и 4 Label (для удобства тестирования)
Добавляем

Код:

References - Microsoft HTML Object Library и Microsoft VBScript Regular Expressions 5.5.

В коде формы -

Код:

Option Explicit
Dim bPageDownoadComplete As Boolean
Dim bFrameDownoadComplete As Boolean
Dim intMaxTimeOut As Integer
Dim LoopCounter As Integer
Dim InitTimeOut As Integer
Dim Increment As Integer
Dim mbConnected As Boolean
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Sub brwIPChanger_DocumentComplete(ByVal pDisp As Object, URL As Variant)
bFrameDownoadComplete = True
If pDisp Is brwIPChanger.Object Then
bPageDownoadComplete = True
End If
End Sub

Public Sub ChangeIP()
Dim bContinue As Boolean
intMaxTimeOut = (gintMaxTimeOut * 60) - 5
Increment = gintIncrement
LoopCounter = 0
GoToModemScreen
mbConnected = True
bContinue = True
OldIP = GetPublicIP
Label3.Caption = OldIP
NewIP = OldIP
Do While bContinue
InitializeInterval
If mbConnected = True Then
Disconnect
mbConnected = False
End If
If WaitInterval = True Then
bContinue = False
Else
If mbConnected = False Then
Connect
mbConnected = True
End If
NewIP = GetPublicIP
If (NewIP <> OldIP) Then
bContinue = False
End If
End If
Loop
Label4.Caption = NewIP
End Sub

Private Function WaitInterval() As Boolean
WaitInterval = False
Dim StartTime As Date
Dim EndTime As Date
Dim intDiff As Integer
Dim bContinue As Boolean

Label1.Caption = InitTimeOut
Label2.Caption = InitTimeOut
StartTime = Now
intDiff = DateDiff("s", StartTime, Now)

EndTime = DateAdd("s", InitTimeOut, StartTime)
bContinue = True
Do While bContinue
DoEvents
MySleep 1, True

intDiff = DateDiff("s", Now, EndTime)
Debug.Print intDiff
Label2.Caption = intDiff
DoEvents
If EndTime <= Now Then
bContinue = False
End If
If DateDiff("s", StartTime, Now) >= intMaxTimeOut Then
bContinue = False
Connect
mbConnected = True
WaitInterval = True
Else
If intDiff < InitTimeOut And intDiff Mod 10 = 0 Then
CheckStatus
If mbConnected Then
NewIP = NewIP = GetPublicIP

If (NewIP <> OldIP) Then
bContinue = False
Connect
mbConnected = True
WaitInterval = True
Else
Disconnect
mbConnected = False
StartTime = Now
EndTime = DateAdd("s", InitTimeOut, StartTime)
intDiff = DateDiff("s", StartTime, Now)
Label1.Caption = InitTimeOut
Label2.Caption = InitTimeOut
End If
End If
End If

End If
Loop

End Function

Private Sub GoToModemScreen()
'Microsoft confirmed bug that for invisible WebBrowser we could
'be in indefinite loop
bPageDownoadComplete = False
Dim strTemp As String
Dim StartTime As Date
Dim Differ As Integer
StartTime = Now
strTemp = "http://" & UserName & ":" & Password & "@192.168.1.1/indexConWan.htm"
brwIPChanger.Navigate2 strTemp, 2
Do While Not bPageDownoadComplete
DoEvents
Differ = DateDiff("s", StartTime, Now)
If Differ > 10 Then
Exit Do
End If
Loop
StartTime = Now
Do While brwIPChanger.ReadyState <> READYSTATE_COMPLETE And brwIPChanger.Busy = True
Differ = DateDiff("s", StartTime, Now)
If Differ > 10 Then
Exit Do
End If
Loop
End Sub

Private Sub InitializeInterval()
InitTimeOut = gInitTimeOut + LoopCounter * Increment
If LoopCounter > 0 Then
Increment = CInt(Increment * 1.5)
End If
LoopCounter = LoopCounter + 1
End Sub

Private Sub WaitForBrowser()
Dim StartTime As Date
Dim Differ As Integer

StartTime = Now
Do While Not bFrameDownoadComplete
DoEvents
Differ = DateDiff("s", StartTime, Now)
If Differ > 10 Then
Exit Do
End If
Loop
WaitForStatus
End Sub

Private Sub WaitForStatus()
Dim doc As New HTMLDocument
Dim strTemp As String
Dim Differ As Integer
Dim StartTime As Date
Dim bContinue As Boolean
StartTime = Now

Do While brwIPChanger.ReadyState <> READYSTATE_COMPLETE And brwIPChanger.Busy = True
Differ = DateDiff("s", StartTime, Now)
If Differ > 10 Then
Exit Do
End If
Loop
Do While brwIPChanger.Document.frames(0).Document.getElementById("conProfileDiv") Is Nothing
DoEvents
Loop
bContinue = True
Do While bContinue
Set doc = brwIPChanger.Document.frames(0).Document
strTemp = doc.getElementById("conProfileDiv").innerHTML
If (InStr(1, strTemp, "Connecting...", vbBinaryCompare) > 0) Then
bContinue = True
Else
If (InStr(1, strTemp, "Disconnecting...", vbBinaryCompare) > 0) Then
bContinue = True
Else
bContinue = False
MySleep 1, False
End If
End If
DoEvents
Loop

End Sub

Private Sub Disconnect()
Start:
bFrameDownoadComplete = False
brwIPChanger.Document.frames(0).Document.parentWindow.execScript "abortPPP(0)", "javascript"
WaitForBrowser
WriteToLog ("Disconnected - ")
CheckStatus
If (mbConnected = True) Then
GoToModemScreen
WriteToLog ("Disconnection Failed - ")
GoTo Start
End If
End Sub

Private Sub Connect()
Start:
bFrameDownoadComplete = False
brwIPChanger.Document.frames(0).Document.parentWindow.execScript "connectPPP(0)", "javascript"
WaitForBrowser
WriteToLog ("Connected - ")
CheckStatus
If (mbConnected = False) Then
GoToModemScreen
WriteToLog ("Connection Failed - ")
GoTo Start
End If
End Sub

Private Sub CheckStatus()
Dim doc As New HTMLDocument
Dim strTemp As String
Dim Ret As Integer
WaitForStatus

Set doc = brwIPChanger.Document.frames(0).Document
strTemp = doc.getElementById("conProfileDiv").innerHTML
Ret = InStr(1, strTemp, ">Up<", vbBinaryCompare)
If Ret > 0 Then
mbConnected = True
End If
Ret = InStr(1, strTemp, ">Down<", vbBinaryCompare)
If Ret > 0 Then
mbConnected = False
End If
End Sub

Private Sub MySleep(Seconds As Integer, Optional UseSleep As Boolean = False)
Dim Date1 As Date
Dim DateTemp As Date

Date1 = Now

DateTemp = DateAdd("s", Seconds, Date1)
Do While Now < DateTemp
DoEvents
If UseSleep Then
Sleep 1000
DoEvents
End If
Loop

End Sub

Добавлено:

Модерирует : ShIvADeSt
Версия для печати • Подписаться • Добавить в закладки
На первую страницу • к этому сообщению • к последнему сообщению