Imports System.Runtime. InteropServices
Public Class ras
Private Const RAS_MaxEntryNam e As Integer = 256
Private Const RAS_MaxPhoneNum ber As Integer = 128
Private Const UNLEN As Integer = 256
Private Const PWLEN As Integer = 256
Private Const DNLEN As Integer = 15
Private Const MAX_PATH As Integer = 260
Private Const RAS_MaxDeviceTy pe As Integer = 16
Private Const RAS_MaxDeviceNa me As Integer = 128
Private Const RAS_MaxCallback Number As Integer =
RAS_MaxPhoneNum ber
Private Const ERROR_BUFFER_TO O_SMALL = 603
Private Const RDEOPT_IgnoreMo demSpeaker = 4&
Private Const RDEOPT_SetModem Speaker = &H8S
Private mvarprevioushan dle As IntPtr
Public Declare Auto Function RasGetErrorStri ng Lib "rasapi32.d ll"
(ByVal uErrorValue As Integer, ByVal lpszErrorString As String, ByVal
cBufSize As Integer) As Integer
<StructLayout(L ayoutKind.Seque ntial, Pack:=1,
CharSet:=CharSe t.Auto)> _
Private Structure RASDIALEXTENSIO NS
Public dwSize As Integer
Public dwfOptions As Integer
Public hwndParent As Integer
Public Reserved As Integer
End Structure
<StructLayout(L ayoutKind.Seque ntial, CharSet:=CharSe t.Auto)> _
Public Structure RASDIALPARAMS
Public dwSize As Integer
<MarshalAs(Unma nagedType.ByVal TStr,
SizeConst:=RAS_ MaxEntryName + 1)> Public szEntryName As String
<MarshalAs(Unma nagedType.ByVal TStr,
SizeConst:=RAS_ MaxPhoneNumber + 1)> Public szPhoneNumber As String
<MarshalAs(Unma nagedType.ByVal TStr,
SizeConst:=RAS_ MaxCallbackNumb er + 1)> Public szCallbackNumbe r As
String
<MarshalAs(Unma nagedType.ByVal TStr, SizeConst:=UNLE N + 1)>
Public szUserName As String
<MarshalAs(Unma nagedType.ByVal TStr, SizeConst:=PWLE N + 1)>
Public szPassword As String
<MarshalAs(Unma nagedType.ByVal TStr, SizeConst:=DNLE N + 1)>
Public szDomain As String
End Structure
Public Delegate Function myrasdialfunc(B yVal hrasconn As IntPtr,
ByVal unMsg As Integer, ByVal rasconnstate As Integer, ByVal dwError
As Integer, ByVal dwexterror As Integer) As Integer
Private Declare Auto Function RasDial Lib "rasapi32.d ll" (ByRef
lpRasDialExtens ions As RASDIALEXTENSIO NS, ByVal lpszPhonebook As
String, ByRef lpRasDialParams As RASDIALPARAMS, ByVal dwNotifierType
As Integer, ByVal lpvNotifier As myrasdialfunc, ByRef lphRasConn As
IntPtr) As Integer
Public Declare Auto Function RasHangUp Lib "rasapi32.d ll" (ByVal
hRasConn As IntPtr) As Integer
<StructLayout(L ayoutKind.Seque ntial, Pack:=4,
CharSet:=CharSe t.Auto)> _
Public Structure RASCONN
Public dwSize As Integer
Public hRasCon As IntPtr
<MarshalAs(Unma nagedType.ByVal TStr,
sizeconst:=RAS_ MaxEntryName + 1)> Public szEntryname As String
<MarshalAs(Unma nagedType.ByVal TStr,
sizeconst:=RAS_ MaxDeviceType + 1)> Public szDeviceType As String
<MarshalAs(Unma nagedType.ByVal TStr,
sizeconst:=RAS_ MaxDeviceName + 1)> Public szDeviceName As String
End Structure
Private Declare Auto Function RasEnumConnecti ons Lib
"rasapi32.d ll" (ByVal lpRasCon As IntPtr, ByRef lpcb As Integer, ByRef
lpcConnections As Integer) As Integer
<StructLayout(L ayoutKind.Seque ntial, CharSet:=CharSe t.Auto)> _
Public Structure RASENTRYNAME
Public dwSize As Integer
<MarshalAs(Unma nagedType.ByVal TStr,
SizeConst:=RAS_ MaxEntryName + 1)> Public szEntryName As String
Public dwFlags As Integer
<MarshalAs(Unma nagedType.ByVal TStr, SizeConst:=MAX_ PATH + 1)>
Public szPhonebookPath As String
End Structure
Private Declare Auto Function RasEnumEntries Lib "rasapi32.d ll"
(ByVal lpStrNull As String, ByVal lpszPhonebook As String, ByVal
lpRasEntryName As IntPtr, ByRef lpCb As Integer, ByRef lpCEntries As
Integer) As Integer
Public Property PreviousHandle( ) As IntPtr
Get
Return mvarprevioushan dle
End Get
Set(ByVal Value As IntPtr)
mvarprevioushan dle = Value
End Set
End Property
Public Sub EnumEntries(ByR ef mincoming() As RASENTRYNAME)
Dim entries() As RASENTRYNAME
Dim rasentrynamelen As Integer =
Marshal.SizeOf( GetType(RASENTR YNAME))
Dim lpcb As Integer = rasentrynamelen
Dim lpcentries As Integer
Dim parray As IntPtr = Marshal.AllocHG lobal(rasentryn amelen)
Marshal.WriteIn t32(parray, rasentrynamelen )
Dim ret As Integer = RasEnumEntries( Nothing, Nothing, parray,
lpcb, lpcentries)
If ret = ERROR_BUFFER_TO O_SMALL Then
parray = Marshal.ReAlloc HGlobal(parray, New IntPtr(lpcb))
Marshal.WriteIn t32(parray, rasentrynamelen )
ret = RasEnumEntries( Nothing, Nothing, parray, lpcb,
lpcentries)
ElseIf ret <> 0 Then
Throw New Exception(GetRa sError(ret))
End If
If ret = 0 And lpcentries > 0 Then
ReDim entries(lpcentr ies - 1)
Dim pentry As IntPtr = parray
Dim i As Integer
For i = 0 To lpcentries - 1
entries(i) = Marshal.PtrToSt ructure(pentry,
GetType(RASENTR YNAME))
pentry = New IntPtr(pentry.T oInt32 + rasentrynamelen )
Next
pentry = Nothing
End If
Marshal.FreeHGl obal(parray)
mincoming = entries
entries = Nothing
End Sub
Public Sub EnumConnections (ByRef mincoming() As RASCONN)
Dim structtype As Type = GetType(RASCONN )
Dim structsize As Integer = Marshal.SizeOf( GetType(RASCONN ))
Dim bufsize As Integer = structsize
Dim realcount As Integer
Dim TRasCon() As RASCONN
Dim bufptr As IntPtr = Marshal.AllocHG lobal(structsiz e)
Marshal.WriteIn t32(bufptr, structsize)
Dim retcode As Integer = RasEnumConnecti ons(bufptr, bufsize,
realcount)
If retcode = ERROR_BUFFER_TO O_SMALL Then
bufptr = Marshal.ReAlloc HGlobal(bufptr, New
IntPtr(bufsize) )
Marshal.WriteIn t32(bufptr, structsize)
retcode = RasEnumConnecti ons(bufptr, bufsize, realcount)
ElseIf retcode <> 0 Then
Throw New Exception(GetRa sError(retcode) )
End If
If (retcode = 0) And (realcount > 0) Then
ReDim TRasCon(realcou nt - 1)
Dim i As Integer
Dim runptr As IntPtr = bufptr
For i = 0 To (realcount - 1)
TRasCon(i) = Marshal.PtrToSt ructure(runptr,
structtype)
runptr = New IntPtr(runptr.T oInt32 + structsize)
Next
runptr = Nothing
End If
Marshal.FreeHGl obal(bufptr)
mincoming = TRasCon
TRasCon = Nothing
End Sub
Public Function DialEntry(ByVal mentryname As String, ByVal
musername As String, ByVal mpassword As String, ByVal mcallback As
myrasdialfunc) As IntPtr
Dim objRASParams As New RASDIALPARAMS()
Dim mvarRasExtensio n As New RASDIALEXTENSIO NS()
Dim hRASConn As New IntPtr()
With mvarRasExtensio n
.hwndParent = 0&
.Reserved = 0
.dwfOptions = RDEOPT_IgnoreMo demSpeaker
.dwSize = Marshal.SizeOf( GetType(RASDIAL EXTENSIONS))
End With
With objRASParams
.szEntryName = mentryname
.szPhoneNumber = ""
.szCallbackNumb er = ""
.szUserName = musername
.szPassword = mpassword
.szDomain = "*"
.dwSize = Marshal.SizeOf( GetType(RASDIAL PARAMS))
End With
Dim intRet As Integer = RasDial(mvarRas Extension, Nothing,
objRASParams, 1, mcallback, hRASConn)
If intRet <> 0 Then
Dim errorstring As String = GetRasError(int Ret)
If errorstring.Ind exOf("already being dialed") Then
If hRASConn.Equals (IntPtr.Zero) = False Then
RasHangUp(hRASC onn)
If mvarprevioushan dle.Equals(IntP tr.Zero) = False Then
RasHangUp(mvarp revioushandle)
End If
Throw New Exception(error string)
End If
DialEntry = hRASConn
objRASParams = Nothing
hRASConn = Nothing
mvarRasExtensio n = Nothing
End Function
Public Sub HangEntry(ByVal mentryname As String)
Dim structtype As Type = GetType(RASCONN )
Dim structsize As Integer = Marshal.SizeOf( GetType(RASCONN ))
Dim bufsize As Integer = structsize
Dim realcount As Integer
Dim TRasCon() As RASCONN
Dim bufptr As IntPtr = Marshal.AllocHG lobal(structsiz e)
Marshal.WriteIn t32(bufptr, structsize)
Dim retcode As Integer = RasEnumConnecti ons(bufptr, bufsize,
realcount)
If retcode = ERROR_BUFFER_TO O_SMALL Then
bufptr = Marshal.ReAlloc HGlobal(bufptr, New
IntPtr(bufsize) )
Marshal.WriteIn t2(bufptr, structsize)
retcode = RasEnumConnecti ons(bufptr, bufsize, realcount)
ElseIf retcode <> 0 Then
Throw New Exception(GetRa sError(retcode) )
End If
If (retcode = 0) And (realcount > 0) Then
ReDim TRasCon(realcou nt - 1)
Dim i As Integer
Dim runptr As IntPtr = bufptr
For i = 0 To (realcount - 1)
TRasCon(i) = Marshal.PtrToSt ructure(runptr,
structtype)
runptr = New IntPtr(runptr.T oInt32 + structsize)
Next
Dim m As RASCONN
For Each m In TRasCon
If m.szEntryname = mentryname Then
RasHangUp(m.hRa sCon)
End If
Next
runptr = Nothing
End If
Marshal.FreeHGl obal(bufptr)
bufptr = Nothing
End Sub
Public Function IsConnected(ByV al mentryname As String) As Boolean
Dim structtype As Type = GetType(RASCONN )
Dim structsize As Integer = Marshal.SizeOf( GetType(RASCONN ))
Dim bufsize As Integer = structsize
Dim entrycount As Integer
Dim entries() As RASCONN
Dim bufptr As IntPtr = Marshal.AllocHG lobal(structsiz e)
Marshal.WriteIn t32(bufptr, structsize)
Dim retcode As Integer = RasEnumConnecti ons(bufptr, bufsize,
entrycount)
If retcode = ERROR_BUFFER_TO O_SMALL Then
bufptr = Marshal.ReAlloc HGlobal(bufptr, New
IntPtr(bufsize) )
Marshal.WriteIn t32(bufptr, structsize)
retcode = RasEnumConnecti ons(bufptr, bufsize, entrycount)
ElseIf retcode <> 0 Then
Throw New Exception(GetRa sError(retcode) )
End If
If (retcode = 0) And (entrycount > 0) Then
ReDim entries(entryco unt - 1)
Dim i As Integer
Dim runptr As IntPtr = bufptr
For i = 0 To (entrycount - 1)
entries(i) = Marshal.PtrToSt ructure(runptr,
structtype)
runptr = New IntPtr(runptr.T oInt32 + structsize)
Next
runptr = Nothing
Dim mEntry As RASCONN
For Each mEntry In entries
If mEntry.szEntryn ame = mentryname Then
IsConnected = True
End If
Next
End If
Marshal.FreeHGl obal(bufptr)
bufptr = Nothing
End Function
Private Function GetRasError(ByV al dwerror As Integer) As String
Dim sErrMsg As New String(Space(51 2))
Dim lret As Integer
lret = ras.RasGetError String(dwerror, sErrMsg, Len(sErrMsg))
If lret = 0 Then
sErrMsg = sErrMsg.Remove( sErrMsg.IndexOf (Chr(0)),
Len(sErrMsg) - sErrMsg.IndexOf (Chr(0)))
GetRasError = "Error # " & dwerror & "; Error Description:
" & sErrMsg
Else
GetRasError = "Unknown RAS Error"
End If
End Function
End Class
''''''''''''''' ''The form can be called anything, paste the following
Imports System.IO
Imports System.Net
Public Class frmRAS
Inherits System.Windows. Forms.Form
Private mvarvpncallback As ras.myrasdialfu nc = AddressOf
VPNRasDialFunc
Private mvarispcallback As ras.myrasdialfu nc = AddressOf
ISPRasDialFunc
Private mvarProgramName As String
Private mvarvpnconnecti onname As String
Private mvarvpnusername As String
Private mvarvpnpassword As String
Private mvarvpnretryint erval As Integer
Private mvarispconnecti onname As String
Private mvarispusername As String
Private mvarisppassword As String
Private mvarispretryint erval As Integer
Private mvarvpnprevhand le As IntPtr
Private mvarispprevhand le As IntPtr
Private Function VPNRasDialFunc( ByVal hrasconn As IntPtr, ByVal
unMsg As Integer, ByVal rasconnstate As Integer, ByVal dwError As
Integer, ByVal dwexterror As Integer) As Integer
'Debug.WriteLin e("DF: " & unMsg.ToString & " - " &
rasconnstate.To String & " - " & dwError.ToStrin g)
'If dwError <> 0 Then Debug.WriteLine (GetRasError(dw Error))
Try
If dwError <> 0 Then
ras.RasHangUp(h rasconn)
Throw New System.Exceptio n(GetRasError(d wError))
End If
Catch exp As Exception
ErrorToXML(exp)
End Try
End Function
Private Function ISPRasDialFunc( ByVal hrasconn As IntPtr, ByVal
unMsg As Integer, ByVal rasconnstate As Integer, ByVal dwError As
Integer, ByVal dwexterror As Integer) As Integer
'Debug.WriteLin e("DF: " & unMsg.ToString & " - " &
rasconnstate.To String & " - " & dwError.ToStrin g)
'If dwError <> 0 Then Debug.WriteLine (GetRasError(dw Error))
Try
If dwError <> 0 Then
ras.RasHangUp(h rasconn)
Throw New System.Exceptio n(GetRasError(d wError))
End If
Catch exp As Exception
ErrorToXML(exp)
End Try
End Function
''''''''''''''F ill in all the usernames and passwords as appropriate
Private Sub GetRegistrySett ings()
Try
mvarvpnusername = "VPNUserNam e"
mvarvpnconnecti onname = "VPNConnectionN ame"
mvarvpnpassword = "VPNPasswor d"
mvarvpnretryint erval = "VPNRetryInterv al"
mvarispusername = "ISPUserNam e"
mvarispconnecti onname = "ISPConnectionN ame"
mvarisppassword = "ISPPassowr d"
Catch exp As Exception
ErrorToXML(exp)
Finally
mvarcregistry = Nothing
End Try
End Sub
Private Sub ErrorToXML(ByVa l exp As Exception)
Try
MessageBox.Show (exp.ToString)
Catch expprivate As Exception
MessageBox.Show (exp.ToString)
Finally
'nothing
End Try
End Sub
Private Sub frmRAS_Load(ByV al sender As System.Object, ByVal e As
System.EventArg s) Handles MyBase.Load
If (UBound(Diagnos tics.Process.Ge tProcessesByNam e(Diagnostics.P rocess.GetCurre ntProcess.Proce ssName))
0) = True Then
Me.Close()
End If
mvarProgramName = System.Windows. Forms.Applicati on.ProductName
& " " & System.Windows. Forms.Applicati on.ProductVersi on
Try
GetRegistrySett ings()
Catch exp As Exception
ErrorToXML(exp)
End Try
End Sub
''''''''''''Thi s is the main function that calls the RAS class. The
previous handle, if it failed, must be hung, before trying to redial.
This program was designed to keep the computer on the internet and vpn
indefinately.
Private Sub tmrDialer_Tick( ByVal sender As System.Object, ByVal e
As System.EventArg s) Handles tmrDialer.Tick
Dim mvarVPNRas As New ras(), mvarISPRAS As New ras(),
mvartemphandle As New IntPtr()
Try
If mvarispretryint erval > 0 Then
If Now.Minute Mod mvarispretryint erval = 0 Then
If mvarISPRAS.IsCo nnected(mvarisp connectionname) =
False Then
If mvarispprevhand le.Equals(IntPt r.Zero) =
False Then mvarISPRAS.Prev iousHandle = mvarispprevhand le
mvartemphandle =
mvarISPRAS.Dial Entry(mvarispco nnectionname, mvarispusername ,
mvarisppassword , mvarispcallback )
If mvartemphandle. Equals(IntPtr.Z ero) = False
Then mvarispprevhand le = mvartemphandle
End If
End If
End If
Catch exp As Exception
ErrorToXML(exp)
End Try
Try
If mvarvpnretryint erval > 0 Then
If Now.Minute Mod mvarvpnretryint erval = 0 Then
If mvarVPNRas.IsCo nnected(mvarvpn connectionname) =
False Then
If mvarvpnprevhand le.Equals(IntPt r.Zero) =
False Then mvarVPNRas.Prev iousHandle = mvarvpnprevhand le
mvartemphandle =
mvarVPNRas.Dial Entry(mvarvpnco nnectionname, mvarvpnusername ,
mvarvpnpassword , mvarvpncallback )
If mvartemphandle. Equals(IntPtr.Z ero) = False
Then mvarvpnprevhand le = mvartemphandle
End If
End If
End If
Catch exp As Exception
ErrorToXML(exp)
End Try
mvarVPNRas = Nothing
mvarISPRAS = Nothing
mvartemphandle = Nothing
End Sub
Private Function GetRasError(ByV al dwerror As Integer) As String
Dim sErrMsg As New String(Space(51 2))
Dim lret As Integer
lret = ras.RasGetError String(dwerror, sErrMsg, Len(sErrMsg))
If lret = 0 Then
sErrMsg = sErrMsg.Remove( sErrMsg.IndexOf (Chr(0)),
Len(sErrMsg) - sErrMsg.IndexOf (Chr(0)))
GetRasError = "Error # " & dwerror & "; Error Description:
" & sErrMsg
Else
GetRasError = "Unknown RAS Error"
End If
End Function
End Class
