Option Explicit
Call Main 'Execute the entry function
'- ----------------------------------------- -
' Function description: Program entry
'- ----------------------------------------- -
Sub Main()
Dim objWsh
Dim objEnv
Dim strNewIP, strOldIP
Dim dtStartTime
Dim nInstance
strOldIP = ""
dtStartTime = DateAdd("n", -30, Now) 'Set the start time
'Get the number of running instances. If it is greater than 1, the previous running instance is ended.
Set objWsh = CreateObject("")
Set objEnv = CreateObject("").Environment("System")
nInstance = Val(objEnv("GetIpToEmail")) + 1 'The number of running instances is added to 1
objEnv("GetIpToEmail") = nInstance
If nInstance > 1 Then Exit Sub 'If the number of running instances is greater than 1, exit, in case of repeated runs
'Open remote desktop
'EnabledRometeDesktop True, Null
'Continuously detect external network addresses in the background, and if there is any change, send an email to the specified email address.
Do
If <> 0 Then Exit Do
If DateDiff("n", dtStartTime, Now) >= 30 Then 'Check IP once every half hour
dtStartTime = Now 'Reset the start time
strNewIP = GetWanIP 'Get the local public IP address
If Len(strNewIP) > 0 Then
If strNewIP <> strOldIP Then 'Send if the IP changes
SendMail "Send email@", "Password", "Recipient email@", "Router IP", strNewIP 'Send IP to the specified email
strOldIP = strNewIP 'Reset the original IP
End If
End If
End If
2000 'Delay 2 seconds to release CPU resources
Loop Until Val(objEnv("GetIpToEmail")) > 1
"GetIpToEmail" 'Clear the number of run instance variable
Set objEnv = Nothing
Set objWsh = Nothing
MsgBox "The program was successfully terminated!", 64, "Prompt"
End Sub
'- ----------------------------------------- -
' Function description: Turn on the remote desktop
' Parameter description: Whether blnEnabled is enabled, True is enabled, False is turned off
' The port number of nPort remote desktop, default is 3389
'- ----------------------------------------- -
Sub EnabledRometeDesktop(blnEnabled, nPort)
Dim objWsh
If blnEnabled Then
blnEnabled = 0 '0 means on
Else
blnEnabled = 1 '1 means close
End If
Set objWsh = CreateObject("")
'Open the remote desktop and set the port number
"HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/fDenyTSConnections", blnEnabled, "REG_DWORD" 'Open Remote Desktop
'Set the remote desktop port number
If IsNumeric(nPort) Then
If nPort > 0 Then
"HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/Wds/rdpwd/Tds/tcp/PortNumber", nPort, "REG_DWORD"
"HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/WinStations/RDP-Tcp/PortNumber", nPort, "REG_DWORD"
End If
End If
Set objWsh = Nothing
End Sub
'- ----------------------------------------- -
' Function description: Obtain the public network IP
'- ----------------------------------------- -
Function GetWanIP()
Dim nPos
Dim objXmlHTTP
GetWanIP = ""
On Error Resume Next
'Create XMLHTTP object
Set objXmlHTTP = CreateObject("")
'Navigate to http:/// to obtain the IP address
"GET", "http://iframe./", False
'Extract the IP address string in HTML
nPos = InStr(, "[")
If nPos > 0 Then
GetWanIP = Mid(, nPos + 1)
nPos = InStr(GetWanIP, "]")
If nPos > 0 Then GetWanIP = Trim(Left(GetWanIP, nPos - 1))
End If
'Destroy XMLHTTP object
Set objXmlHTTP = Nothing
End Function
'- ----------------------------------------- -
' Function description: Convert string to numeric value
'- ----------------------------------------- -
Function Val(vNum)
If IsNumeric(vNum) Then
Val = CDbl(vNum)
Else
Val = 0
End If
End Function
'- ----------------------------------------- -
' Function description: Send email
' Parameter description: strEmailFrom: sender's email
' strPassword: sender's email password
' strEmailTo: recipient's email
' strSubject: Email Title
' strText: Email content
'- ----------------------------------------- -
Function SendMail(strEmailFrom, strPassword, strEmailTo, strSubject, strText)
Dim i, nPos
Dim strUsername
Dim strSmtpServer
Dim objSock
Dim strEML
Const sckConnected = 7
Set objSock = CreateWinsock()
= 0
nPos = InStr(strEmailFrom, "@")
'Check the integrity and legality of parameters
If nPos = 0 Or InStr(strEmailTo, "@") = 0 Or Len(strText) = 0 Or Len(strPassword) = 0 Then Exit Function
'Get the email account based on the email name
strUsername = Trim(Left(strEmailFrom, nPos - 1))
'Get the ESMTP server name based on the sender's email address
strSmtpServer = "smtp." & Trim(Mid(strEmailFrom, nPos + 1))
'Assemble email
strEML = "MIME-Version: 1.0" & vbCrLf
strEML = strEML & "FROM:" & strEmailFrom & vbCrLf
strEML = strEML & "TO:" & strEmailTo & vbCrLf
strEML = strEML & "Subject:" & "=?GB2312?B?" & Base64Encode(strSubject) & "?=" & vbCrLf
strEML = strEML & "Content-Type: text/plain;" & vbCrLf
strEML = strEML & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf
strEML = strEML & Base64Encode(strText)
strEML = strEML & vbCrLf & "." & vbCrLf
'Connect to the mail service cry
strSmtpServer, 25
'Waiting for the connection to be successful
For i = 1 To 10
If = sckConnected Then Exit For
200
Next
If = sckConnected Then
'Prepare to send an email
SendCommand objSock, "EHLO VBSEmail"
SendCommand objSock, "AUTH LOGIN" 'Application for SMTP session
SendCommand objSock, Base64Encode(strUsername)
SendCommand objSock, Base64Encode(strPassword)
SendCommand objSock, "MAIL FROM:" & strEmailFrom 'Sendor
SendCommand objSock, "RCPT TO:" & strEmailTo 'Recipient
SendCommand objSock, "DATA" 'The following is the email content
'Send an email
SendCommand objSock, strEML
'End email send
SendCommand objSock, "QUIT"
End If
'Disconnect
200
Set objSock = Nothing
End Function
'- ----------------------------------------- -
' Function description: SendMail's helper function
'- ----------------------------------------- -
Function SendCommand(objSock, strCommand)
Dim i
Dim strEcho
On Error Resume Next
strCommand & vbCrLf
For i = 1 To 50 'Waiting for the result
200
If > 0 Then
strEcho, vbString
If (Val(strEcho) > 0 And Val(strEcho) < 400) Or InStr(strEcho, "+OK") > 0 Then
SendCommand = True
End If
Exit Function
End If
Next
End Function
'- ----------------------------------------- -
' Function description: Create a Winsock object. If it fails, download and register before creating it.
'- ----------------------------------------- -
Function CreateWinsock()
Dim objWsh
Dim objXmlHTTP
Dim objAdoStream
Dim objFSO
Dim strSystemPath
'Create and return Winsock object
On Error Resume Next
Set CreateWinsock = CreateObject("")
If = 0 Then Exit Function 'Create successfully, return the Winsock object
On Error GoTo 0
'Get the Windows/System32 system folder location
Set objFSO = CreateObject("")
strSystemPath = (1)
'If the file in the system folder does not exist, download it from the website
If Not (strSystemPath & "/") Then
'Create XMLHTTP object
Set objXmlHTTP = CreateObject("")
'Download the control
"GET", ":81/?FileId=223358", False
'It will be saved to the system folder
Set objAdoStream = CreateObject("")
= 1 'adTypeBinary
strSystemPath & "/", 2 'adSaveCreateOverwrite
Set objAdoStream = Nothing
'Destroy XMLHTTP object
Set objXmlHTTP = Nothing
End If
'register
Set objWsh = CreateObject("")
"HKEY_CLASSES_ROOT/Licenses/2c49f800-c2dd-11cf-9ad6-0080c7e7b78d/", "mlrljgrlhltlngjlthrligklpkrhllglqlrk" 'Add license
"regsvr32 /s " & strSystemPath & "/", 0 'Register control
Set objWsh = Nothing
'Recreate and return Winsock object
Set CreateWinsock = CreateObject("")
End Function
'- ----------------------------------------- -
' Function description: BASE64 encoding function
'- ----------------------------------------- -
Function Base64Encode(strSource)
Dim objXmlDOM
Dim objXmlDocNode
Dim objAdoStream
Base64Encode = ""
If strSource = "" Or IsNull(strSource) Then Exit Function
'Create XML document object
Set objXmlDOM = CreateObject("")
("<?xml version='1.0' ?> <root/>")
Set objXmlDocNode = ("MyText")
= "bin.base64"
'Convert string to byte array
Set objAdoStream = CreateObject("")
= 3
= 2
= "GB2312"
strSource
= 0
= 1
= () 'Read the converted byte array into the XML document
Set objAdoStream = Nothing
'Get BASE64 encoding
Base64Encode =
objXmlDocNode
Set objXmlDOM = Nothing
End Function
Call Main 'Execute the entry function
'- ----------------------------------------- -
' Function description: Program entry
'- ----------------------------------------- -
Sub Main()
Dim objWsh
Dim objEnv
Dim strNewIP, strOldIP
Dim dtStartTime
Dim nInstance
strOldIP = ""
dtStartTime = DateAdd("n", -30, Now) 'Set the start time
'Get the number of running instances. If it is greater than 1, the previous running instance is ended.
Set objWsh = CreateObject("")
Set objEnv = CreateObject("").Environment("System")
nInstance = Val(objEnv("GetIpToEmail")) + 1 'The number of running instances is added to 1
objEnv("GetIpToEmail") = nInstance
If nInstance > 1 Then Exit Sub 'If the number of running instances is greater than 1, exit, in case of repeated runs
'Open remote desktop
'EnabledRometeDesktop True, Null
'Continuously detect external network addresses in the background, and if there is any change, send an email to the specified email address.
Do
If <> 0 Then Exit Do
If DateDiff("n", dtStartTime, Now) >= 30 Then 'Check IP once every half hour
dtStartTime = Now 'Reset the start time
strNewIP = GetWanIP 'Get the local public IP address
If Len(strNewIP) > 0 Then
If strNewIP <> strOldIP Then 'Send if the IP changes
SendMail "Send email@", "Password", "Recipient email@", "Router IP", strNewIP 'Send IP to the specified email
strOldIP = strNewIP 'Reset the original IP
End If
End If
End If
2000 'Delay 2 seconds to release CPU resources
Loop Until Val(objEnv("GetIpToEmail")) > 1
"GetIpToEmail" 'Clear the number of run instance variable
Set objEnv = Nothing
Set objWsh = Nothing
MsgBox "The program was successfully terminated!", 64, "Prompt"
End Sub
'- ----------------------------------------- -
' Function description: Turn on the remote desktop
' Parameter description: Whether blnEnabled is enabled, True is enabled, False is turned off
' The port number of nPort remote desktop, default is 3389
'- ----------------------------------------- -
Sub EnabledRometeDesktop(blnEnabled, nPort)
Dim objWsh
If blnEnabled Then
blnEnabled = 0 '0 means on
Else
blnEnabled = 1 '1 means close
End If
Set objWsh = CreateObject("")
'Open the remote desktop and set the port number
"HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/fDenyTSConnections", blnEnabled, "REG_DWORD" 'Open Remote Desktop
'Set the remote desktop port number
If IsNumeric(nPort) Then
If nPort > 0 Then
"HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/Wds/rdpwd/Tds/tcp/PortNumber", nPort, "REG_DWORD"
"HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Control/Terminal Server/WinStations/RDP-Tcp/PortNumber", nPort, "REG_DWORD"
End If
End If
Set objWsh = Nothing
End Sub
'- ----------------------------------------- -
' Function description: Obtain the public network IP
'- ----------------------------------------- -
Function GetWanIP()
Dim nPos
Dim objXmlHTTP
GetWanIP = ""
On Error Resume Next
'Create XMLHTTP object
Set objXmlHTTP = CreateObject("")
'Navigate to http:/// to obtain the IP address
"GET", "http://iframe./", False
'Extract the IP address string in HTML
nPos = InStr(, "[")
If nPos > 0 Then
GetWanIP = Mid(, nPos + 1)
nPos = InStr(GetWanIP, "]")
If nPos > 0 Then GetWanIP = Trim(Left(GetWanIP, nPos - 1))
End If
'Destroy XMLHTTP object
Set objXmlHTTP = Nothing
End Function
'- ----------------------------------------- -
' Function description: Convert string to numeric value
'- ----------------------------------------- -
Function Val(vNum)
If IsNumeric(vNum) Then
Val = CDbl(vNum)
Else
Val = 0
End If
End Function
'- ----------------------------------------- -
' Function description: Send email
' Parameter description: strEmailFrom: sender's email
' strPassword: sender's email password
' strEmailTo: recipient's email
' strSubject: Email Title
' strText: Email content
'- ----------------------------------------- -
Function SendMail(strEmailFrom, strPassword, strEmailTo, strSubject, strText)
Dim i, nPos
Dim strUsername
Dim strSmtpServer
Dim objSock
Dim strEML
Const sckConnected = 7
Set objSock = CreateWinsock()
= 0
nPos = InStr(strEmailFrom, "@")
'Check the integrity and legality of parameters
If nPos = 0 Or InStr(strEmailTo, "@") = 0 Or Len(strText) = 0 Or Len(strPassword) = 0 Then Exit Function
'Get the email account based on the email name
strUsername = Trim(Left(strEmailFrom, nPos - 1))
'Get the ESMTP server name based on the sender's email address
strSmtpServer = "smtp." & Trim(Mid(strEmailFrom, nPos + 1))
'Assemble email
strEML = "MIME-Version: 1.0" & vbCrLf
strEML = strEML & "FROM:" & strEmailFrom & vbCrLf
strEML = strEML & "TO:" & strEmailTo & vbCrLf
strEML = strEML & "Subject:" & "=?GB2312?B?" & Base64Encode(strSubject) & "?=" & vbCrLf
strEML = strEML & "Content-Type: text/plain;" & vbCrLf
strEML = strEML & "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf
strEML = strEML & Base64Encode(strText)
strEML = strEML & vbCrLf & "." & vbCrLf
'Connect to the mail service cry
strSmtpServer, 25
'Waiting for the connection to be successful
For i = 1 To 10
If = sckConnected Then Exit For
200
Next
If = sckConnected Then
'Prepare to send an email
SendCommand objSock, "EHLO VBSEmail"
SendCommand objSock, "AUTH LOGIN" 'Application for SMTP session
SendCommand objSock, Base64Encode(strUsername)
SendCommand objSock, Base64Encode(strPassword)
SendCommand objSock, "MAIL FROM:" & strEmailFrom 'Sendor
SendCommand objSock, "RCPT TO:" & strEmailTo 'Recipient
SendCommand objSock, "DATA" 'The following is the email content
'Send an email
SendCommand objSock, strEML
'End email send
SendCommand objSock, "QUIT"
End If
'Disconnect
200
Set objSock = Nothing
End Function
'- ----------------------------------------- -
' Function description: SendMail's helper function
'- ----------------------------------------- -
Function SendCommand(objSock, strCommand)
Dim i
Dim strEcho
On Error Resume Next
strCommand & vbCrLf
For i = 1 To 50 'Waiting for the result
200
If > 0 Then
strEcho, vbString
If (Val(strEcho) > 0 And Val(strEcho) < 400) Or InStr(strEcho, "+OK") > 0 Then
SendCommand = True
End If
Exit Function
End If
Next
End Function
'- ----------------------------------------- -
' Function description: Create a Winsock object. If it fails, download and register before creating it.
'- ----------------------------------------- -
Function CreateWinsock()
Dim objWsh
Dim objXmlHTTP
Dim objAdoStream
Dim objFSO
Dim strSystemPath
'Create and return Winsock object
On Error Resume Next
Set CreateWinsock = CreateObject("")
If = 0 Then Exit Function 'Create successfully, return the Winsock object
On Error GoTo 0
'Get the Windows/System32 system folder location
Set objFSO = CreateObject("")
strSystemPath = (1)
'If the file in the system folder does not exist, download it from the website
If Not (strSystemPath & "/") Then
'Create XMLHTTP object
Set objXmlHTTP = CreateObject("")
'Download the control
"GET", ":81/?FileId=223358", False
'It will be saved to the system folder
Set objAdoStream = CreateObject("")
= 1 'adTypeBinary
strSystemPath & "/", 2 'adSaveCreateOverwrite
Set objAdoStream = Nothing
'Destroy XMLHTTP object
Set objXmlHTTP = Nothing
End If
'register
Set objWsh = CreateObject("")
"HKEY_CLASSES_ROOT/Licenses/2c49f800-c2dd-11cf-9ad6-0080c7e7b78d/", "mlrljgrlhltlngjlthrligklpkrhllglqlrk" 'Add license
"regsvr32 /s " & strSystemPath & "/", 0 'Register control
Set objWsh = Nothing
'Recreate and return Winsock object
Set CreateWinsock = CreateObject("")
End Function
'- ----------------------------------------- -
' Function description: BASE64 encoding function
'- ----------------------------------------- -
Function Base64Encode(strSource)
Dim objXmlDOM
Dim objXmlDocNode
Dim objAdoStream
Base64Encode = ""
If strSource = "" Or IsNull(strSource) Then Exit Function
'Create XML document object
Set objXmlDOM = CreateObject("")
("<?xml version='1.0' ?> <root/>")
Set objXmlDocNode = ("MyText")
= "bin.base64"
'Convert string to byte array
Set objAdoStream = CreateObject("")
= 3
= 2
= "GB2312"
strSource
= 0
= 1
= () 'Read the converted byte array into the XML document
Set objAdoStream = Nothing
'Get BASE64 encoding
Base64Encode =
objXmlDocNode
Set objXmlDOM = Nothing
End Function