Attribute VB_Name = "Module1"
'===============================================================================
'===============================================================================
'  Created By: Steven Carter
'  Published Date: 7/14/2004
'  WebSite: www.carterszoo.com
'  Updated: 5/13/2005
'=========================================================+=====================

Option Explicit
'RAS IP Structure Type
Public Type RASIPADDR
    a As Byte
    b As Byte
    C As Byte
    d As Byte
End Type

'Ras Entry Options
Public Enum RasEntryOptions
' 0-3
   RASEO_UseCountryAndAreaCodes = &H1
   RASEO_SpecificIpAddr = &H2
   RASEO_SpecificNameServers = &H4
   RASEO_IpHeaderCompression = &H8
'4-7
   RASEO_RemoteDefaultGateway = &H10
   RASEO_DisableLcpExtensions = &H20
   RASEO_TerminalBeforeDial = &H40
   RASEO_TerminalAfterDial = &H80
'8-11
   RASEO_ModemLights = &H100
   RASEO_SwCompression = &H200
   RASEO_RequireEncryptedPw = &H400
   RASEO_RequireMsEncryptedPw = &H800
'12-15
   RASEO_RequireDataEncryption = &H1000
   RASEO_NetworkLogon = &H2000
   RASEO_UseLogonCredentials = &H4000
   RASEO_PromoteAlternates = &H8000
'16-19
   RASEO_SecureLocalFiles = &H10000
   RASEO_RequireEAP = &H20000
   RASEO_RequirePAP = &H40000
   RASEO_RequireSPAP = &H80000
'20,21,23
   RASEO_Custom = &H100000
   RASEO_PreviewPhoneNumber = &H200000
   RASEO_SharedPhoneNumbers = &H800000
'24-27
   RASEO_PreviewUserPw = &H1000000
   RASEO_PreviewDomain = &H2000000
   RASEO_ShowDialingProgress = &H4000000
   RASEO_RequireCHAP = &H8000000
'28-31
   RASEO_RequireMsCHAP = &H10000000
   RASEO_RequireMsCHAP2 = &H20000000
   RASEO_RequireW95MSCHAP = &H40000000
   RASEO_CustomScript = &H80000000
End Enum

'***************************************************************************
'****Thanks to CHOI LIM JU for helping with the following addition**
'***************************************************************************
Public Enum RasEntryOptions2
   RASEO2_SecureFileAndPrint = &H1 '0x00000001
   RASEO2_SecureClientForMSNet = &H2 '0x00000002
   RASEO2_DontNegotiateMultilink = &H4 '0x00000004
   RASEO2_DontUseRasCredentials = &H8 '0x00000008
   RASEO2_UsePreSharedKey = &H10 '0x00000010
   RASEO2_Internet = &H20 '0x00000020
   RASEO2_DisableNbtOverIP = &H40 '0x00000040
   RASEO2_UseGlobalDeviceSettings = &H80 '0x00000080
   RASEO2_ReconnectIfDropped = &H100 '0x00000100
   RASEO2_SharePhoneNumbers = &H200 '0x00000200
End Enum
'***************************************************************************


Public Enum RASNetProtocols
   RASNP_NetBEUI = &H1
   RASNP_Ipx = &H2
   RASNP_Ip = &H4
End Enum

Public Enum RasFramingProtocols
   RASFP_Ppp = &H1
   RASFP_Slip = &H2
   RASFP_Ras = &H4
End Enum

Public Enum VPNStrategies
    VS_Default = &H0       ' default (PPTP for now)
    VS_PptpOnly = &H1      ' Only PPTP is attempted.
    VS_PptpFirst = &H2      ' PPTP is tried first.
    VS_L2tpOnly = &H3       ' Only L2TP is attempted.
    VS_L2tpFirst = &H4     ' L2TP is tried first.
End Enum

Public Enum dwTypes
   RASET_Phone = 1
   RASET_Vpn = 2
   RASET_Direct = 3
   RASET_Internet = 4
   RASET_Broadband = 5
End Enum

Public Type VBRasEntry
   dwSize As Long
   options As RasEntryOptions
   CountryID As Long
   CountryCode As Long
   AreaCode As String
   LocalPhoneNumber As String
   AlternateNumbers As String
   ipAddr As RASIPADDR
   ipAddrDns As RASIPADDR
   ipAddrDnsAlt As RASIPADDR
   ipAddrWins As RASIPADDR
   ipAddrWinsAlt As RASIPADDR
   FrameSize As Long
   fNetProtocols As RASNetProtocols
   FramingProtocol As RasFramingProtocols
   ScriptName As String
   AutodialDll As String
   AutodialFunc As String
   DeviceType As String
   DeviceName As String
   X25PadType As String
   X25Address As String
   X25Facilities As String
   X25UserData As String
   Channels As Long
   NT4En_SubEntries As Long
   NT4En_DialMode As Long
   NT4En_DialExtraPercent As Long
   NT4En_DialExtraSampleSeconds As Long
   NT4En_HangUpExtraPercent As Long
   NT4En_HangUpExtraSampleSeconds As Long
   NT4En_IdleDisconnectSeconds As Long
   Win2000_Type As dwTypes
   Win2000_EncryptionType As Long
   Win2000_CustomAuthKey As Long
   Win2000_guidId(0 To 15) As Byte
   Win2000_CustomDialDll As String
   Win2000_VpnStrategy As VPNStrategies
'***************************************************************************
'****Thanks to CHOI LIM JU for helping with the following change  **
'***************************************************************************
   WinXP_Options2 As RasEntryOptions2
'***************************************************************************
   WinXP_Options3 As Long
   WinXP_DNSSuffix As String
   WinXP_TcpWindowSize As Long
   WinXP_PrerequisitePbk As String
   WinXP_PrerequisiteEntry As String
   WinXP_RedialCount As Long
   WinXP_RedialPause As Long
End Type



Public Declare Function RasSetEntryProperties Lib "rasapi32.dll"_
    Alias "RasSetEntryPropertiesA" (ByVal lpszPhonebook As String,_
    ByVal lpszEntry As String, lpRasEntry As Any, ByVal dwEntryInfoSize_
    As Long, lpbDeviceInfo As Any, ByVal dwDeviceInfoSize As Long) As Long

Public Declare Function RasGetErrorString Lib "rasapi32.dll" Alias _
    "RasGetErrorStringA" (ByVal uErrorValue As Long, ByVal lpszErrorString _
    As String, cBufSize As Long) As Long

Public Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
    (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long,_
    ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long,_
    Arguments As Long) As Long
       
Public Declare Function RasGetEntryProperties Lib "rasapi32.dll" Alias _
    "RasGetEntryPropertiesA" (ByVal lpszPhonebook As String, ByVal lpszEntry _
    As String, lpRasEntry As Any, lpdwEntryInfoSize As Long, lpbDeviceInfo _
    As Any, lpdwDeviceInfoSize As Long) As Long
        
Public Type VBRASDEVINFO
   DeviceType As String
   DeviceName As String
End Type

Public Declare Function RasEnumDevices Lib "rasapi32.dll" Alias _
    "RasEnumDevicesA" (lpRasDevInfo As Any, lpcb As Long, lpcDevices As Long) As Long


Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (Destination As Any, Source As Any, ByVal Length As Long)
         
Global Const RAS_MaxDeviceType = 16
Global Const RAS_MaxDeviceName = 128

'Constants for GlobalAlloc
Global Const GMEM_FIXED = &H0
Global Const GMEM_ZEROINIT = &H40
Global Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

' Constants needed for LocalAlloc
Global Const LMEM_FIXED = &H0
Global Const LMEM_ZEROINIT = &H40
Global Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

Global Const ERROR_BUFFER_TOO_SMALL = 603

' Constant needed for RASENTRYNAME
Global Const RAS_MaxEntryName = 256

Global Const ApINULL = 0&

' Function prototype for RasEnumEntries
Public Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" ( _
            ByVal reserved As String, _
            ByVal szPhoneBook As String, _
            lpRasEntries As Any, _
            lpcb As Long, _
            lpcEntries As Long) As Long
            
Public Declare Function RasDeleteEntry _
         Lib "rasapi32.dll" Alias "RasDeleteEntryA" _
         (ByVal lpszPhonebook As String, _
         ByVal lpszEntry As String) As Long

    
' Type definition for RASENTRYNAME
Type RASENTRYNAME
    dwSize As Long
    szEntryName(RAS_MaxEntryName) As Byte
End Type

Type RASDEVINFO
    dwSize As Long
    szDeviceType(RAS_MaxDeviceType) As Byte
    szDeviceName(RAS_MaxDeviceName) As Byte
End Type

Declare Function iRasEnumDevices Lib "rasapi32.dll" Alias "RasEnumDevicesA" _
     (lpRasDevInfo As Any, lpcb As Long, lpcDevices As Long) As Long
    
Declare Sub iCopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As _
     Any, hpvSource As Any, ByVal cbCopy As Long)
         
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal _
     dwBytes As Long) As Long

Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

' Function prototype for LocalAlloc
Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal _
     dwBytes As Long) As Long

' Function prototype for LocalFree
Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long


Public Declare Function GetWindowsDirectoryA Lib "kernel32" (ByVal lpBuffer _
     As String, ByVal nSize As Long) As Long

Public Enum DeviceTypeSearch
   FindbyName
   FindbyType
End Enum

Public Enum RASCreationType
   NonSecure5400
   MSRRAS
End Enum




'=========================================================================================
Function FindDevice(strPartialName As String, Optional Findby As DeviceTypeSearch) As String
   Dim lpRasDevInfo As RASDEVINFO
   Dim lpcb As Long
   Dim cDevices As Long
   Dim t_Buff As Long
   Dim nRet As Long
   Dim t_ptr As Long
   Dim i As Long
   Dim sTempString As String

   If IsMissing(Findby) Then
      Findby = FindbyName
   End If

   lpcb = 0

   lpRasDevInfo.dwSize = LenB(lpRasDevInfo) + (LenB(lpRasDevInfo) Mod 4)

   nRet = iRasEnumDevices(ByVal 0, lpcb, cDevices)

   t_Buff = GlobalAlloc(GPTR, lpcb)

   iCopyMemory ByVal t_Buff, lpRasDevInfo, LenB(lpRasDevInfo)

   nRet = iRasEnumDevices(ByVal t_Buff, lpcb, lpcb)

   If nRet = 0 Then
      t_ptr = t_Buff

      For i = 0 To cDevices - 1
         iCopyMemory lpRasDevInfo, ByVal t_ptr, LenB(lpRasDevInfo)
         If Findby = FindbyName Then
            sTempString = (ByteToString(lpRasDevInfo.szDeviceName))
         Else
            sTempString = (ByteToString(lpRasDevInfo.szDeviceType))
         End If
         If InStr(1, sTempString, strPartialName) > 0 Then
            FindDevice = (ByteToString(lpRasDevInfo.szDeviceName))
            Exit For
         End If
         t_ptr = t_ptr + LenB(lpRasDevInfo) + (LenB(lpRasDevInfo) Mod 4)
      Next i
   Else
      App.LogEvent "Error Enumerating Devices: Code " & nRet, vbLogEventTypeError
   End If

   If t_Buff <> 0 Then GlobalFree (t_Buff)

End Function 'FindDevice(strPartialName As String) As String
'===============================================================================
Sub GetDevices(lst As ComboBox)
   Dim lpRasDevInfo As RASDEVINFO
   Dim lpcb As Long
   Dim cDevices As Long
   Dim t_Buff As Long
   Dim nRet As Long
   Dim t_ptr As Long
   Dim i As Long


   lpcb = 0

   lpRasDevInfo.dwSize = LenB(lpRasDevInfo) + (LenB(lpRasDevInfo) Mod 4)

   nRet = iRasEnumDevices(ByVal 0, lpcb, cDevices)

   t_Buff = GlobalAlloc(GPTR, lpcb)

   iCopyMemory ByVal t_Buff, lpRasDevInfo, LenB(lpRasDevInfo)

   nRet = iRasEnumDevices(ByVal t_Buff, lpcb, lpcb)

   If nRet = 0 Then
      t_ptr = t_Buff

      For i = 0 To cDevices - 1
         iCopyMemory lpRasDevInfo, ByVal t_ptr, LenB(lpRasDevInfo)
         lst.AddItem (ByteToString(lpRasDevInfo.szDeviceName))
         t_ptr = t_ptr + LenB(lpRasDevInfo) + (LenB(lpRasDevInfo) Mod 4)
      Next i
   Else
      App.LogEvent "Error in Get Devices.  Error #:" & nRet, vbLogEventTypeError
   End If

   If t_Buff <> 0 Then GlobalFree (t_Buff)

End Sub 'GetDevices(lst As ComboBox)
'===============================================================================
Function ByteToString(bytearray() As Byte) As String
   Dim i As Integer, t As String

   i = 0
   t = ""
   While i < UBound(bytearray) And bytearray(i) <> 0
      t = t & Chr$(bytearray(i))
      i = i + 1
   Wend
   ByteToString = t
End Function 'ByteToString(bytearray() As Byte) As String
'=================================================+============================
Function VBRasSetEntryProperties(strEntryName As String, typRasEntry _
     As VBRasEntry, Optional strPhoneBook As String) As Long


   Dim rtn As Long, lngCb As Long, lngBuffLen As Long
   Dim b() As Byte
   Dim lngPos As Long, lngStrLen As Long

   rtn = RasGetEntryProperties(vbNullString, vbNullString, ByVal 0&, lngCb, ByVal 0&, ByVal 0&)

   If rtn <> 603 Then VBRasSetEntryProperties = rtn: Exit Function

   lngStrLen = Len(typRasEntry.AlternateNumbers)
   lngBuffLen = lngCb + lngStrLen + 1
   ReDim b(lngBuffLen)

   CopyMemory b(0), lngCb, 4
   CopyMemory b(4), typRasEntry.options, 4
   CopyMemory b(8), typRasEntry.CountryID, 4
   CopyMemory b(12), typRasEntry.CountryCode, 4
   CopyStringToByte b(16), typRasEntry.AreaCode, 11
   CopyStringToByte b(27), typRasEntry.LocalPhoneNumber, 129

   If lngStrLen > 0 Then
      CopyMemory b(lngCb), ByVal typRasEntry.AlternateNumbers, lngStrLen
      CopyMemory b(156), lngCb, 4
   End If

   CopyMemory b(160), typRasEntry.ipAddr, 4
   CopyMemory b(164), typRasEntry.ipAddrDns, 4
   CopyMemory b(168), typRasEntry.ipAddrDnsAlt, 4
   CopyMemory b(172), typRasEntry.ipAddrWins, 4
   CopyMemory b(176), typRasEntry.ipAddrWinsAlt, 4
   CopyMemory b(180), typRasEntry.FrameSize, 4
   CopyMemory b(184), typRasEntry.fNetProtocols, 4
   CopyMemory b(188), typRasEntry.FramingProtocol, 4
   CopyStringToByte b(192), typRasEntry.ScriptName, 260
   CopyStringToByte b(452), typRasEntry.AutodialDll, 260
   CopyStringToByte b(712), typRasEntry.AutodialFunc, 260
   CopyStringToByte b(972), typRasEntry.DeviceType, 17
   If lngCb = 1672& Then lngStrLen = 33 Else lngStrLen = 129
   CopyStringToByte b(989), typRasEntry.DeviceName, lngStrLen
   lngPos = 989 + lngStrLen
   CopyStringToByte b(lngPos), typRasEntry.X25PadType, 33
   lngPos = lngPos + 33
   CopyStringToByte b(lngPos), typRasEntry.X25Address, 201
   lngPos = lngPos + 201
   CopyStringToByte b(lngPos), typRasEntry.X25Facilities, 201
   lngPos = lngPos + 201
   CopyStringToByte b(lngPos), typRasEntry.X25UserData, 201
   lngPos = lngPos + 203
   CopyMemory b(lngPos), typRasEntry.Channels, 4

   If lngCb > 1768 Then
      CopyMemory b(1768), typRasEntry.NT4En_SubEntries, 4
      CopyMemory b(1772), typRasEntry.NT4En_DialMode, 4
      CopyMemory b(1776), typRasEntry.NT4En_DialExtraPercent, 4
      CopyMemory b(1780), typRasEntry.NT4En_DialExtraSampleSeconds, 4
      CopyMemory b(1784), typRasEntry.NT4En_HangUpExtraPercent, 4
      CopyMemory b(1788), typRasEntry.NT4En_HangUpExtraSampleSeconds, 4
      CopyMemory b(1792), typRasEntry.NT4En_IdleDisconnectSeconds, 4

      If lngCb > 1796 Then
         CopyMemory b(1796), typRasEntry.Win2000_Type, 4
         CopyMemory b(1800), typRasEntry.Win2000_EncryptionType, 4
         CopyMemory b(1804), typRasEntry.Win2000_CustomAuthKey, 4
         CopyMemory b(1808), typRasEntry.Win2000_guidId(0), 16
         CopyStringToByte b(1824), typRasEntry.Win2000_CustomDialDll, 260
         CopyMemory b(2084), typRasEntry.Win2000_VpnStrategy, 4

         If lngCb > 2088 Then
            CopyMemory b(2088), typRasEntry.WinXP_Options2, 4
            CopyMemory b(2092), typRasEntry.WinXP_Options3, 4
            CopyStringToByte b(2096), typRasEntry.WinXP_DNSSuffix, 260
         End If
      End If

   End If

   rtn = RasSetEntryProperties(strPhoneBook, strEntryName, b(0), lngCb, ByVal 0&, ByVal 0&)

   VBRasSetEntryProperties = rtn

End Function 'VBRasSetEntryProperties(strEntryName As String, typRasEntry As VBRasEntry, 
             'Optional strPhoneBook As String) As Long
'=========================================================================================
Function VBRASErrorHandler(rtn As Long) As String
   Dim strError As String, i As Long

   strError = String(512, 0)
   If rtn > 600 Then
      RasGetErrorString rtn, strError, 512&
   Else
      FormatMessage &H1000, ByVal 0&, rtn, 0&, strError, 512, ByVal 0&
   End If
   i = InStr(strError, Chr$(0))
   If i > 1 Then VBRASErrorHandler = Left$(strError, i - 1)
End Function 'VBRASErrorHandler(rtn As Long) As String
'=========================================================================================
Function VBRasGetEntryProperties(strEntryName As String, typRasEntry As VBRasEntry, _
     Optional strPhoneBook As String) As Long


   Dim rtn As Long, lngCb As Long, lngBuffLen As Long
   Dim b() As Byte
   Dim lngPos As Long, lngStrLen As Long



   rtn = RasGetEntryProperties(vbNullString, vbNullString, ByVal 0&, lngCb, ByVal 0&, ByVal 0&)
   'MsgBox "lngCB:" & CStr(lngCb)

   rtn = RasGetEntryProperties(strPhoneBook, strEntryName, ByVal 0&, lngBuffLen, ByVal 0&, ByVal 0&)
   'MsgBox "StrPhoneBook: " & strPhoneBook
   'MsgBox "lngBuffLen: " & lngBuffLen


   If rtn <> 603 Then VBRasGetEntryProperties = rtn: Exit Function

   ReDim b(lngBuffLen - 1)
   CopyMemory b(0), lngCb, 4

   rtn = RasGetEntryProperties(strPhoneBook, strEntryName, b(0), lngBuffLen, ByVal 0&, ByVal 0&)

   VBRasGetEntryProperties = rtn
   If rtn <> 0 Then Exit Function

   CopyMemory typRasEntry.options, b(4), 4
   CopyMemory typRasEntry.CountryID, b(8), 4
   CopyMemory typRasEntry.CountryCode, b(12), 4
   CopyByteToTrimmedString typRasEntry.AreaCode, b(16), 11
   CopyByteToTrimmedString typRasEntry.LocalPhoneNumber, b(27), 129

   CopyMemory lngPos, b(156), 4
   If lngPos <> 0 Then
      lngStrLen = lngBuffLen - lngPos
      typRasEntry.AlternateNumbers = String(lngStrLen, 0)
      CopyMemory ByVal typRasEntry.AlternateNumbers, b(lngPos), lngStrLen
   End If

   CopyMemory typRasEntry.ipAddr, b(160), 4
   CopyMemory typRasEntry.ipAddrDns, b(164), 4
   CopyMemory typRasEntry.ipAddrDnsAlt, b(168), 4
   CopyMemory typRasEntry.ipAddrWins, b(172), 4
   CopyMemory typRasEntry.ipAddrWinsAlt, b(176), 4
   CopyMemory typRasEntry.FrameSize, b(180), 4
   CopyMemory typRasEntry.fNetProtocols, b(184), 4
   CopyMemory typRasEntry.FramingProtocol, b(188), 4
   CopyByteToTrimmedString typRasEntry.ScriptName, b(192), 260
   CopyByteToTrimmedString typRasEntry.AutodialDll, b(452), 260
   CopyByteToTrimmedString typRasEntry.AutodialFunc, b(712), 260
   CopyByteToTrimmedString typRasEntry.DeviceType, b(972), 17
   If lngCb = 1672& Then lngStrLen = 33 Else lngStrLen = 129
   CopyByteToTrimmedString typRasEntry.DeviceName, b(989), lngStrLen
   lngPos = 989 + lngStrLen
   CopyByteToTrimmedString typRasEntry.X25PadType, b(lngPos), 33
   lngPos = lngPos + 33
   CopyByteToTrimmedString typRasEntry.X25Address, b(lngPos), 201
   lngPos = lngPos + 201
   CopyByteToTrimmedString typRasEntry.X25Facilities, b(lngPos), 201
   lngPos = lngPos + 201
   CopyByteToTrimmedString typRasEntry.X25UserData, b(lngPos), 201
   lngPos = lngPos + 203
   CopyMemory typRasEntry.Channels, b(lngPos), 4

   If lngCb > 1768 Then
      CopyMemory typRasEntry.NT4En_SubEntries, b(1768), 4
      CopyMemory typRasEntry.NT4En_DialMode, b(1772), 4
      CopyMemory typRasEntry.NT4En_DialExtraPercent, b(1776), 4
      CopyMemory typRasEntry.NT4En_DialExtraSampleSeconds, b(1780), 4
      CopyMemory typRasEntry.NT4En_HangUpExtraPercent, b(1784), 4
      CopyMemory typRasEntry.NT4En_HangUpExtraSampleSeconds, b(1788), 4
      CopyMemory typRasEntry.NT4En_IdleDisconnectSeconds, b(1792), 4

      If lngCb > 1796 Then
         CopyMemory typRasEntry.Win2000_Type, b(1796), 4
         CopyMemory typRasEntry.Win2000_EncryptionType, b(1800), 4
         CopyMemory typRasEntry.Win2000_CustomAuthKey, b(1804), 4
         CopyMemory typRasEntry.Win2000_guidId(0), b(1808), 16
         CopyByteToTrimmedString typRasEntry.Win2000_CustomDialDll, b(1824), 260
         CopyMemory typRasEntry.Win2000_VpnStrategy, b(2084), 4
         CopyMemory typRasEntry.WinXP_Options2, b(2088), 4
         CopyMemory typRasEntry.WinXP_Options3, b(2092), 4
         CopyByteToTrimmedString typRasEntry.WinXP_DNSSuffix, b(2096), 260

      End If

   End If




End Function 'VBRasGetEntryProperties(strEntryName As String, typRasEntry As VBRasEntry, 
             'Optional strPhoneBook As String) As Long
'=========================================================================================
Function VBRasEnumDevices(clsVBRasDevInfo() As VBRASDEVINFO) As Long
   Dim rtn As Long, i As Long
   Dim lpcb As Long, lpcDevices As Long
   Dim b() As Byte
   Dim dwSize As Long


   rtn = RasEnumDevices(ByVal 0&, lpcb, lpcDevices)

   If lpcDevices = 0 Then Exit Function

   dwSize = lpcb \ lpcDevices

   ReDim b(lpcb - 1)

   CopyMemory b(0), dwSize, 4

   rtn = RasEnumDevices(b(0), lpcb, lpcDevices)

   If lpcDevices = 0 Then Exit Function

   ReDim clsVBRasDevInfo(lpcDevices - 1)

   For i = 0 To lpcDevices - 1
      CopyByteToTrimmedString clsVBRasDevInfo(i).DeviceType, b((i * dwSize) + 4), 17
      CopyByteToTrimmedString clsVBRasDevInfo(i).DeviceName, b((i * dwSize) + 21), dwSize - 21
   Next i

   VBRasEnumDevices = lpcDevices

End Function 'VBRasEnumDevices(clsVBRasDevInfo() As VBRASDEVINFO) As Long
'=========================================================================================
Sub CopyByteToTrimmedString(strToCopyTo As String, bPos As Byte, lngMaxLen As Long)


   Dim strTemp As String, lngLen As Long
   strTemp = String(lngMaxLen + 1, 0)
   CopyMemory ByVal strTemp, bPos, lngMaxLen
   lngLen = InStr(strTemp, Chr$(0)) - 1
   strToCopyTo = Left$(strTemp, lngLen)

End Sub 'CopyByteToTrimmedString(strToCopyTo As String, bPos As Byte, lngMaxLen As Long)
'=========================================================================================
Sub CopyStringToByte(bPos As Byte, strToCopy As String, lngMaxLen As Long)
   Dim lngLen As Long

   lngLen = Len(strToCopy)
   If lngLen = 0 Then
      Exit Sub
   ElseIf lngLen > lngMaxLen Then
      lngLen = lngMaxLen
   End If
   CopyMemory bPos, ByVal strToCopy, lngLen

End Sub 'CopyStringToByte(bPos As Byte, strToCopy As String, lngMaxLen As Long)
'=========================================================================================
Public Function GetEntries(ByRef sEntryName() As String) As Integer
   Dim tRasEntryName As RASENTRYNAME
   Dim cb As Long
   Dim cEntries As Long
   Dim t_Buff As Long
   Dim t_ptr As Long
   Dim nRet As Long
   Dim i As Long
   Dim iTempCount As Integer

   iTempCount = 0
   cb = LenB(tRasEntryName)
   ReDim sEntryName(40)
   ' Initialize the dwSize field
   tRasEntryName.dwSize = cb

   ' Allocate input buffer with enough room for at least one structure
   t_Buff = LocalAlloc(LPTR, cb)

   If (t_Buff) Then
      ' Initialize the first entry
      ' Since t_Buff is the actual memory address we need to pass it by value (ByVal)
      ' to CopyMemory because VB passes parameters by reference by default
      Call iCopyMemory(ByVal t_Buff, tRasEntryName, LenB(tRasEntryName))

      ' Call RasEnumEntries to enumerate the phonebook entries
      ' in the default system phonebook
      nRet = RasEnumEntries(vbNullString, vbNullString, ByVal t_Buff, cb, cEntries)

      'Check return value
      If (ERROR_BUFFER_TOO_SMALL = nRet And cb <> 0) Then
         Call LocalFree(t_Buff)
         t_Buff = LocalAlloc(LPTR, cb)
      ElseIf (0 <> nRet) Then
         App.LogEvent "RasEnumEntries failed: Error  " & CStr(nRet), vbLogEventTypeError


         Call LocalFree(t_Buff)
         Exit Function
      End If

      If (t_Buff) Then
         If (nRet <> 0) Then
            Call iCopyMemory(ByVal t_Buff, tRasEntryName, LenB(tRasEntryName))

            ' Call RasEnumEntries to enumerate the phonebook entries
            ' in the default system phonebook
            nRet = RasEnumEntries(vbNullString, vbNullString, ByVal t_Buff, cb, cEntries)
         End If

         If nRet = 0 Then ' RasEnumEntries returned success
            t_ptr = t_Buff

            ' Copy the values of the first entry
            Call iCopyMemory(tRasEntryName, ByVal t_ptr, LenB(tRasEntryName))

            ' Add phonebook entries to the combo box
            For i = 1 To cEntries
               Call iCopyMemory(tRasEntryName, ByVal t_ptr, LenB(tRasEntryName))
               iTempCount = iTempCount + 1
               sEntryName(iTempCount) = (ByteToString(tRasEntryName.szEntryName))
               t_ptr = t_ptr + tRasEntryName.dwSize
            Next i
         Else
            App.LogEvent "RasEnumEntries failed = " & CStr(nRet), vbLogEventTypeError
         End If

         ' Free the allocated input buffer
         Call LocalFree(t_Buff)

      Else ' RasEnumEntries returned an error
         App.LogEvent "LocalAlloc failed!" & CStr(nRet), vbLogEventTypeError
      End If


   Else
      App.LogEvent "LocalAlloc failed!" & CStr(nRet), vbLogEventTypeError
   End If
   If iTempCount > 0 Then
      ReDim Preserve sEntryName(iTempCount)
   End If
   GetEntries = iTempCount
End Function 'GetEntries(ByRef sEntryName() As String) As Integer
'=========================================================================================

Attribute VB_Name = "modMain"
Option Explicit
Public Const MAXIMUM_COMMAND_ARGUMENTS = 20
Public Const MARKER_TEXTFILE_NAME = "Connectoid03.txt"
'-----------------------------------------------------
' Version history for the marker file
'
' Begin with - "Connectoid.txt" = Only created the 4 Secure VPN connections
' 2004 07 20 - "Connectoid01.txt" = Added 3 Secure RAS connections (AH,SD,SR)
' 2004 08 05 - "Connectoid02.txt" = added 1 new secure RAS connection (UK)
' 2004 08 20 - "Connectoid03.txt" = added the DNS suffix "xyz.xyz.com" to all the connectoids
'

Sub Main()
Dim cmdArgCount As Integer
Dim cmdArgs() As String
Dim strVPNDevice As String
Dim strModemDevice As String
Dim i As Integer
Dim fStop As Boolean
Dim fOptionIgnoreOS As Boolean
Dim fOptionDeleteOldVPN As Boolean
Dim fOptionLeaveOldRAS As Boolean
Dim fUseDefaultGateway As Boolean
Dim fUserInterfaceVisible As Boolean
Dim sRASConnectionName() As String
Dim iRASEntriesCount As Integer
Dim ans As Long
Dim sTempServerName As String
Dim tmpVBRasEntry As VBRasEntry
Dim fDeleteOK As Boolean


fStop = False
fOptionIgnoreOS = False
fOptionDeleteOldVPN = False
fOptionLeaveOldRAS = False
fUseDefaultGateway = True
fUserInterfaceVisible = False


cmdArgs = GetCommandLine(MAXIMUM_COMMAND_ARGUMENTS)
cmdArgCount = UBound(cmdArgs)

Debug.Assert MsgBox("Upper bounds for command line is " & cmdArgCount)

If cmdArgCount > 0 Then

For i = 1 To cmdArgCount
Select Case LCase(Right(cmdArgs(i), Len(cmdArgs(i)) - 1))

Case "?", "help"

frmHelp.Show vbModal
fStop = True

Case "diag"
fStop = True
Form1.Show

Case "nodefaultgateway"
fUseDefaultGateway = False

Case "ignoreos"
fOptionIgnoreOS = True


Case "deleteoldvpn"
fOptionDeleteOldVPN = True
Debug.Assert MsgBox("Delete old VPN?")
Case "leaveoldras"
fOptionLeaveOldRAS = True

Case "force"
Debug.Assert MsgBox("Force Create VPN?")

' Case "ui"
' fUserInterfaceVisible = True
' fStop = True
' frmUI.Show

Case Else
MsgBox "What is (" & cmdArgs(i) & ")?"
fStop = True
End Select

Next i

End If
If fStop = False Then

strVPNDevice = FindDevice("PPTP", FindbyName)
CreateVPNEntry "Secure VPN - S R", "secure-sr.xyz.com", strVPNDevice, fUseDefaultGateway
CreateVPNEntry "Secure VPN - A H", "secure-ah.xyz.com", strVPNDevice, fUseDefaultGateway
CreateVPNEntry "Secure VPN - S D", "secure-sd.xyz.com", strVPNDevice, fUseDefaultGateway
CreateVPNEntry "Secure VPN - UK", "secure-uk.xyz.com", strVPNDevice, fUseDefaultGateway
Debug.Assert MsgBox(GetWindowsDirectory)

'**************-------------
'*
'* Options
'*
'**************-------------

'Delete old VPN's Option

If fOptionDeleteOldVPN = True Then
iRASEntriesCount = GetEntries(sRASConnectionName)
If iRASEntriesCount < 1 Then
'we got problems because there should be some connections... particularly the secures vpn above
Else
For i = 1 To iRASEntriesCount
'TODO: Look for old vpn connections
Debug.Assert MsgBox(sRASConnectionName(i))
If VBRasGetEntryProperties(sRASConnectionName(i), tmpVBRasEntry) = 0 Then
Debug.Assert MsgBox(tmpVBRasEntry.LocalPhoneNumber)
sTempServerName = Trim(LCase(tmpVBRasEntry.LocalPhoneNumber))
fDeleteOK = False
If sTempServerName = "sr.xyz.com" Then fDeleteOK = True
If sTempServerName = "ah.xyz.com" Then fDeleteOK = True
If sTempServerName = "sd.xyz.com" Then fDeleteOK = True
If sTempServerName = "uk.xyz.com" Then fDeleteOK = True
If sTempServerName = "sr1.xyz.com" Then fDeleteOK = True
If sTempServerName = "ah1.xyz.com" Then fDeleteOK = True
If sTempServerName = "sd1.xyz.com" Then fDeleteOK = True
If sTempServerName = "uk1.xyz.com" Then fDeleteOK = True
If sTempServerName = "0.99.34.2" Then fDeleteOK = True
If sTempServerName = "0.99.223.2" Then fDeleteOK = True
If sTempServerName = "0.99.159.2" Then fDeleteOK = True
If sTempServerName = "0.99.50.2" Then fDeleteOK = True


If fDeleteOK = True Then

ans = RasDeleteEntry(vbNullString, sRASConnectionName(i))
If ans = 0 Then
App.LogEvent "Removed old connection '" & sRASConnectionName(i)
Else
'didn't delete it
Debug.Assert MsgBox("RASDELETEENTRY Returns " & ans)
App.LogEvent "Couldn't remove old connection '" & sRASConnectionName(i)
End If
End If
End If
Next i

End If
Debug.Assert MsgBox("Connection Count is " & iRASEntriesCount)


End If ' option for delete old vpn


'Create Secure RAS Connections
strModemDevice = FindDevice("modem", FindbyType)
If strModemDevice = "" Then
     App.LogEvent "Secure VPN did not make any RAS connectoids because no modem was found", _
          vbLogEventTypeInformation
     Debug.Assert MsgBox("No modem")
Else
     Debug.Assert MsgBox(strModemDevice)
     CreateRASEntry "Secure RAS - S R", "1", "415", "555-1212", strModemDevice, NonSecure5400
     CreateRASEntry "Secure RAS - A H", "1", "651", "555-1212", strModemDevice, NonSecure5400
     CreateRASEntry "Secure RAS - S D", "1", "858", "555-1212", strModemDevice, NonSecure5400
     CreateRASEntry "Secure RAS - UK", "44", "", "0800 5555 321", strModemDevice, MSRRAS

End If

'This text marker is a way to see the process completed.
'Also it is inventorable by LANDesk and I think SMS

CreateTextMarker




App.LogEvent "Secure VPN App is now ending", vbLogEventTypeInformation
Else
App.LogEvent "Secure VPN did not finish", vbLogEventTypeWarning
End If
End Sub


Function GetCommandLine(Optional MaxArgs)
'Declare variables.
   Dim C As String
   Dim CmdLine As String
   Dim CmdLnLen As Integer
   Dim InArg As Boolean
   Dim i As Integer
   Dim NumArgs As Integer
   'See if MaxArgs was provided.
   If IsMissing(MaxArgs) Then MaxArgs = 10
   'Make array of the correct size.
   ReDim ArgArray(MaxArgs) As String
   NumArgs = 0: InArg = False
   'Get command line arguments.
   CmdLine = Command()
   CmdLnLen = Len(CmdLine)
   'Go thru command line one character
   'at a time.
   For i = 1 To CmdLnLen
      C = Mid(CmdLine, i, 1)
      'Test for space or tab.
      If (C <> " " And C <> vbTab) Then
      'Neither space nor tab.
      'Test if already in argument.
      If Not InArg Then
      'New argument begins.
      'Test for too many arguments.
         If NumArgs = MaxArgs Then Exit For
            NumArgs = NumArgs + 1
            InArg = True
         End If
         'Concatenate character to current argument.
         ArgArray(NumArgs) = ArgArray(NumArgs) & C
      Else
         'Found a space or tab.
         'Set InArg flag to False.
         InArg = False
      End If
   Next i
   'Resize array just enough to hold arguments.
   ReDim Preserve ArgArray(NumArgs)
   'Return Array in Function name.
   GetCommandLine = ArgArray()
End Function

Private Sub CreateVPNEntry(ByVal sConnectoidName As String, ByVal sVPNServer As String, ByVal _
     sDeviceName As String, Optional ByVal fSetDefaultGateway As Boolean)

Dim typVBRasEntry As VBRasEntry

If IsMissing(fSetDefaultGateway) Then
fSetDefaultGateway = True
End If

'typVBRasEntry.AreaCode = ""
'typVBRasEntry.AutodialFunc = 0
'typVBRasEntry.CountryCode = "1"
'typVBRasEntry.CountryID = "1"
typVBRasEntry.DeviceName = sDeviceName
typVBRasEntry.DeviceType = "vpn"
typVBRasEntry.fNetProtocols = RASNP_Ip
typVBRasEntry.FramingProtocol = RASFP_Ppp
If fSetDefaultGateway = True Then
     typVBRasEntry.options = CLng(RASEO_IpHeaderCompression + RASEO_RemoteDefaultGateway + RASEO_ModemLights + _
          RASEO_SwCompression + RASEO_RequireDataEncryption + RASEO_NetworkLogon + RASEO_UseLogonCredentials + _
          RASEO_RequireEAP + RASEO_Custom + RASEO_PreviewUserPw + RASEO_PreviewDomain + RASEO_ShowDialingProgress)
Else
     typVBRasEntry.options = CLng(RASEO_IpHeaderCompression + RASEO_ModemLights + RASEO_SwCompression + _
         RASEO_RequireDataEncryption + RASEO_NetworkLogon + RASEO_UseLogonCredentials + RASEO_RequireEAP + _
         RASEO_Custom + RASEO_PreviewUserPw + RASEO_PreviewDomain + RASEO_ShowDialingProgress)
End If
'typVBRasEntry.options = CLng(txtOptions.Text)
typVBRasEntry.Win2000_CustomAuthKey = 15
typVBRasEntry.Win2000_EncryptionType = 1
typVBRasEntry.Win2000_Type = 2
typVBRasEntry.Win2000_VpnStrategy = VS_PptpFirst

typVBRasEntry.ipAddrDns.a = "0"
typVBRasEntry.ipAddrDns.b = "0"
typVBRasEntry.ipAddrDns.C = "0"
typVBRasEntry.ipAddrDns.d = "0"
typVBRasEntry.ipAddrDnsAlt.a = "0"
typVBRasEntry.ipAddrDnsAlt.b = "0"
typVBRasEntry.ipAddrDnsAlt.C = "0"
typVBRasEntry.ipAddrDnsAlt.d = "0"
typVBRasEntry.ipAddrWins.a = "0"
typVBRasEntry.ipAddrWins.b = "0"
typVBRasEntry.ipAddrWins.C = "0"
typVBRasEntry.ipAddrWins.d = "0"
typVBRasEntry.ipAddrWinsAlt.a = "0"
typVBRasEntry.ipAddrWinsAlt.b = "0"
typVBRasEntry.ipAddrWinsAlt.C = "0"
typVBRasEntry.ipAddrWinsAlt.d = "0"
typVBRasEntry.LocalPhoneNumber = sVPNServer
typVBRasEntry.WinXP_DNSSuffix = "corp.xyz.com"
Dim rtn As Long

rtn = VBRasSetEntryProperties(sConnectoidName, typVBRasEntry)
If rtn <> 0 Then
App.LogEvent "Could not create VPN connectoid (" & sConnectoidName & ") to " & _
     sVPNServer & ". Error code was " & rtn

End If



End Sub

Private Sub CreateRASEntry(ByVal sConnectoidName As String, ByVal sCountryCode As String, ByVal _
     sAreaCode As String, ByVal sLocalNumber As String, ByVal sDeviceName As String, Optional ByVal _
     ServerType As RASCreationType = NonSecure5400)

Dim typVBRasEntry As VBRasEntry

If IsEmpty(ServerType) Then
     ServerType = NonSecure5400
End If

typVBRasEntry.AreaCode = sAreaCode
typVBRasEntry.AutodialFunc = 0
typVBRasEntry.CountryCode = sCountryCode
typVBRasEntry.CountryID = sCountryCode
typVBRasEntry.DeviceName = sDeviceName
typVBRasEntry.DeviceType = "modem"
typVBRasEntry.fNetProtocols = RASNP_Ip
typVBRasEntry.FramingProtocol = RASFP_Ppp
If ServerType = NonSecure5400 Then
     typVBRasEntry.options = CLng(RASEO_UseCountryAndAreaCodes + RASEO_IpHeaderCompression + _
          RASEO_RemoteDefaultGateway + RASEO_ModemLights + RASEO_SwCompression + RASEO_RequirePAP + _
          RASEO_Custom + RASEO_PreviewPhoneNumber + RASEO_SharedPhoneNumbers + _
          RASEO_PreviewUserPw + RASEO_ShowDialingProgress)
     typVBRasEntry.Win2000_CustomAuthKey = 0
     typVBRasEntry.Win2000_EncryptionType = 0
     typVBRasEntry.Win2000_Type = 1

Else
     typVBRasEntry.options = CLng(RASEO_UseCountryAndAreaCodes + RASEO_IpHeaderCompression +  _
     RASEO_RemoteDefaultGateway + RASEO_ModemLights + RASEO_SwCompression + RASEO_RequireDataEncryption + _
     RASEO_NetworkLogon + RASEO_UseLogonCredentials + RASEO_RequireEAP + RASEO_Custom + RASEO_PreviewUserPw + _
     RASEO_PreviewDomain + RASEO_ShowDialingProgress)
     typVBRasEntry.Win2000_CustomAuthKey = 15
     typVBRasEntry.Win2000_EncryptionType = 1
     typVBRasEntry.Win2000_Type = 1

End If

typVBRasEntry.ipAddrDns.a = "0"
typVBRasEntry.ipAddrDns.b = "0"
typVBRasEntry.ipAddrDns.C = "0"
typVBRasEntry.ipAddrDns.d = "0"
typVBRasEntry.ipAddrDnsAlt.a = "0"
typVBRasEntry.ipAddrDnsAlt.b = "0"
typVBRasEntry.ipAddrDnsAlt.C = "0"
typVBRasEntry.ipAddrDnsAlt.d = "0"
typVBRasEntry.ipAddrWins.a = "0"
typVBRasEntry.ipAddrWins.b = "0"
typVBRasEntry.ipAddrWins.C = "0"
typVBRasEntry.ipAddrWins.d = "0"
typVBRasEntry.ipAddrWinsAlt.a = "0"
typVBRasEntry.ipAddrWinsAlt.b = "0"
typVBRasEntry.ipAddrWinsAlt.C = "0"
typVBRasEntry.ipAddrWinsAlt.d = "0"
typVBRasEntry.WinXP_DNSSuffix = "corp.xyz.com"
typVBRasEntry.LocalPhoneNumber = sLocalNumber
'***************************************************************************
'****Thanks to CHOI LIM JU for helping with the following change  **
'***************************************************************************
'Set redial if dropped
typVBRasEntry.WinXP_Options2 = RASEO2_ReconnectIfDropped
'***************************************************************************


Dim rtn As Long

rtn = VBRasSetEntryProperties(sConnectoidName, typVBRasEntry)
If rtn <> 0 Then
App.LogEvent "Could not create VPN connectoid (" & sConnectoidName & ") to " & sLocalNumber & _
     ". Error code was " & rtn

End If



End Sub
Public Function AddBackslash(s As String) As String
If Len(s & "X") > 1 Then
If Right$(s, 1) <> "\" Then
AddBackslash = s + "\"
Else
AddBackslash = s
End If
Else
AddBackslash = "\"
End If
End Function



Public Function GetWindowsDirectory() As String
Dim s As String
Dim i As Integer
i = GetWindowsDirectoryA("", 0)
s = Space(i)
Call GetWindowsDirectoryA(s, i)
GetWindowsDirectory = AddBackslash(Left$(s, i - 1))
End Function

Sub CreateTextMarker()

On Error GoTo CreateTextMark_Err
Dim sMarkerFile As String
Dim xFile As Integer


xFile = FreeFile

sMarkerFile = GetWindowsDirectory & MARKER_TEXTFILE_NAME
Open sMarkerFile For Append As xFile
Close xFile
Exit Sub

CreateTextMark_Err:

App.LogEvent "Error Creating Text Marker. Error Number: " & Err.Number & _
     " - " & Err.Description, vbLogEventTypeError
Resume Next


End Sub