كيفية الإتصال بالأنترنت من خلال برنامج مع تعديل البروكسي والمنفذ وكلمة المرور برمجياً

الكود التالي ينشئ لك اسم اتصال جديد ، وهو طويل جدا وأظن أن فيه شيء زائد عن الحاجة :

===========================

برنامج لإنشاء اتصال جديد مع رقم الهاتف وكامل خصائص الاتصال

أنشئ قائمة منسدلة لإظهار المودومات الموجودة في الجهاز باسم cboDevices .

أنشئ زر أمر باسم cmdCreateConnection .

في الوحدة النمطية الخاصة بالنموذج ضع الأسطر التالية :

Private Sub cmdCreateConnection_Click()

CreateNewEntry

End Sub

Private Sub cmdExit_Click()

Unload Me

End Sub

'list devices installed in combobox lstDevice

Private Sub Form_Load()

ListDevices

If cboDevices.ListCount = 0 Then cmdCreateConnection.Enabled = False

End Sub

Private Sub ListDevices()

cboDevices.Clear

GetDevices cboDevices

If cboDevices.ListCount > 0 Then cboDevices.ListIndex = 0

End Sub

Private Sub CreateNewEntry()

'make the DUN called DUN_NAME

'Will work if the selected device in the combo box is a modem

'The Connection Created is a "dummy" one

'If you want a real one, change the below parameters

'to the what you need, or add text boxes to a form

'so the user can enter them him/herself

Dim typVBRasEntry As VBRasEntry

typVBRasEntry.AreaCode = ""

typVBRasEntry.AutodialFunc = 0

typVBRasEntry.CountryCode = "1"

typVBRasEntry.CountryID = "1"

typVBRasEntry.DeviceName = cboDevices.Text

typVBRasEntry.DeviceType = "Modem"

typVBRasEntry.fNetProtocols = RASNP_Ip

typVBRasEntry.FramingProtocol = RASFP_Ppp

typVBRasEntry.options = RASEO_SwCompression + RASEO_IpHeaderCompression + RASEO_RemoteDefaultGateway _

+ RASEO_SpecificNameServers

typVBRasEntry.ipAddrDns.a = "206"

typVBRasEntry.ipAddrDns.b = "211"

typVBRasEntry.ipAddrDns.c = "214"

typVBRasEntry.ipAddrDns.d = "206"

typVBRasEntry.ipAddrDnsAlt.a = "212"

typVBRasEntry.ipAddrDnsAlt.b = "200"

typVBRasEntry.ipAddrDnsAlt.c = "200"

typVBRasEntry.ipAddrDnsAlt.d = "200"

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 = "555-5555"

Dim rtn As Long

rtn = VBRasSetEntryProperties("DUN NAME", typVBRasEntry)

If rtn <> 0 Then

MsgBox VBRASErrorHandler(rtn)

Else

MsgBox "DUN Created.", vbOKOnly, "Complete"

End If

End Sub

وفي الوحدة النمطية العامة ضع الأسطر التالية :

Option Explicit

Public Type RASIPADDR

a As Byte

b As Byte

c As Byte

d As Byte

End Type

Public Enum RasEntryOptions

RASEO_UseCountryAndAreaCodes = &H1

RASEO_SpecificIpAddr = &H2

RASEO_SpecificNameServers = &H4

RASEO_IpHeaderCompression = &H8

RASEO_RemoteDefaultGateway = &H10

RASEO_DisableLcpExtensions = &H20

RASEO_TerminalBeforeDial = &H40

RASEO_TerminalAfterDial = &H80

RASEO_ModemLights = &H100

RASEO_SwCompression = &H200

RASEO_RequireEncryptedPw = &H400

RASEO_RequireMsEncryptedPw = &H800

RASEO_RequireDataEncryption = &H1000

RASEO_NetworkLogon = &H2000

RASEO_UseLogonCredentials = &H4000

RASEO_PromoteAlternates = &H8000

RASEO_SecureLocalFiles = &H10000

RASEO_RequireEAP = &H20000

RASEO_RequirePAP = &H40000

RASEO_RequireSPAP = &H80000

RASEO_Custom = &H100000

RASEO_PreviewPhoneNumber = &H200000

RASEO_SharedPhoneNumbers = &H800000

RASEO_PreviewUserPw = &H1000000

RASEO_PreviewDomain = &H2000000

RASEO_ShowDialingProgress = &H4000000

RASEO_RequireCHAP = &H8000000

RASEO_RequireMsCHAP = &H10000000

RASEO_RequireMsCHAP2 = &H20000000

RASEO_RequireW95MSCHAP = &H40000000

RASEO_CustomScript = &H80000000

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 Type VBRasEntry

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 Long

Win2000_EncryptionType As Long

Win2000_CustomAuthKey As Long

Win2000_guidId(0 To 15) As Byte

Win2000_CustomDialDll As String

Win2000_VpnStrategy As Long

End Type

'Make a combo box for the modem devices and use the GetDevices command.

'in the form Dim clsVbRasEntry As VbRasEntry

'make calls as clsVbRasEntry.options = selected options

'clsVbRasEntry.LocalPhoneNumber = "555-5555" and so forth

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

Global Const GMEM_FIXED = &H0

Global Const GMEM_ZEROINIT = &H40

Global Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Global Const ApINULL = 0&

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

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

MsgBox nRet

End If

If t_Buff <> 0 Then GlobalFree (t_Buff)

End Sub

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

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

End If

End If

rtn = RasSetEntryProperties(strPhoneBook, strEntryName, _

b(0), lngCb, ByVal 0&, ByVal 0&)

VBRasSetEntryProperties = rtn

End Function

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

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&)

rtn = RasGetEntryProperties(strPhoneBook, strEntryName, _

ByVal 0&, lngBuffLen, ByVal 0&, ByVal 0&)

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

End If

End If

End Function

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

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

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

وسأوافيك قريبا بكود لتمرير اسم اتصال والاتصال مباشرة بالانترنت أما إعدادات البروكسي فقد بحث ولم أجد شيء .

ولك تحياتي

أخي / أبو حمود

سلام الله عليك ورحمته وبركاته.

جزاك الله خيراً كثيراً على هذا الكود، ووفقك الله لما يحبه ويرضاه.

والله الموفق.،،،

أخي العزيز

أشكرك جداً للمرة الثانية على هذا الكود الرائع، ولكن هذا الكود لايغيير كلمة المرور للإتصال. وهي مهمة جداً

أرجو أن تكون قد حصلت على معلومات أخرى عن الموضوع.

والله الموفق.،،،

هذا كود للإتصال بإنترنت بعد نقر زر أمر ، إذا كنت ترغب في الاتصال المباشر فيحتاج منك إلى تعديل لتمرير اسم اتصال معروف لديك بدلا من الاختيار من القائمة :

، برنامج للإتصال بإنترنت وقطع الاتصال وعرض الحالة

يتكون البرنامج من ثلاثة أزرار أمر باسم cmdConnect وcmdCheck وcmdDisconnect وقائمة منسدلة باسم lstConnections ومربع نص باسم txtStatus . اكتب في الوحدة النمطية الخاصة بالنموذج الأسطر التالية :

Option Explicit

Private WithEvents fInet As WinInet



Private Sub cmdCheck_Click()
    If fInet.Connected Then
        Call AddToStatus("Internet Connection active.")
    Else
        Call AddToStatus("No active Internet Connection.")
    End If
End Sub
Private Sub cmdConnect_Click()
    Dim plResult As Long

    If lstConnections.ListIndex = -1 Then
        MsgBox "Please select a DUN from the listbox before selecting connect.", vbOKOnly + vbExclamation, "WinInet Demo"
    Else
        plResult = fInet.StartDUN(Me.hWnd, lstConnections.List(lstConnections.ListIndex))
        If plResult = 0& Then
            Call AddToStatus("Connection to " & lstConnections.List(lstConnections.ListIndex) & " made.")
        Else
            If plResult = -1 Then
                Call AddToStatus("Already connected.")
            Else
                Call AddToStatus("Error " & plResult & " attempting to connect to " & lstConnections.List(lstConnections.ListIndex))
            End If
        End If
    End If
End Sub
Private Sub cmdDisconnect_Click()
    Dim plResult As Long

    plResult = fInet.HangUp
    If plResult = 0& Then
        Call AddToStatus("Connection terminated.")
    Else
        If plResult = -1 Then
            Call AddToStatus("No connection made yet.")
        Else
            Call AddToStatus("Unable to terminate connection, error: " & plResult)
        End If
    End If
End Sub
Private Sub fInet_ConnectionClosed()
    'this event does not "monitor" the connection status, it is only fired when
    'the .HangUp method is invoked
    Call AddToStatus("Connection closed event fired.")
End Sub
Private Sub fInet_ConnectionMade()
    'this event does not "monitor" the connection status, it is fired when a
    'successfull connection is made via the .StartDUN method
    Call AddToStatus("Connection made event fired.")
End Sub
Private Sub Form_Load()
    Dim psDuns() As String
    Dim piMax As Integer
    Dim piIndex As Integer

    'initialize class
    Set fInet = New WinInet

    'get list of DUNS on the system
    fInet.ListDUNs psDuns
    lstConnections.Clear
    'put list in the listbox
    piMax = -1
    On Error Resume Next
    piMax = UBound(psDuns())
    On Error GoTo 0
    For piIndex = 0 To piMax
        lstConnections.AddItem psDuns(piIndex)
    Next piIndex
    txtStatus.Text = "Class initialized." & vbCrLf
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    'clear reference to class
    Set fInet = Nothing
End Sub
Private Sub AddToStatus(psText As String)
    'add supplied text to box
    txtStatus.Text = txtStatus.Text & psText & vbCrLf
    'scroll text down if necessary
    txtStatus.SelStart = Len(txtStatus.Text)
    txtStatus.SelLength = 0
End Sub
وفي الوحدة النمطية للفئة اكتب الأسطر التالية :
Option Explicit

'   private Module variables
Private mlConnectionNumber As Long
Private mbDisconnectOnTerminate As Boolean

'   for list dun's function
Private Type RAS_ENTRIES
    dwSize As Long
    szEntryname(256) As Byte
End Type
Private Declare Function RasEnumEntriesA Lib "rasapi32.dll" (ByVal reserved As String, ByVal lpszPhonebook As String, lprasentryname As Any, lpcb As Long, lpcEntries As Long) As Long

'   for activeconnection funciton
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal sSubKey As String, hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal sKeyValue As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, nSizeData As Long) As Long

'   for Dial and Hangup functions
Private Declare Function InternetDial Lib "wininet.dll" (ByVal hWnd As Long, ByVal sConnectoid As String, ByVal dwFlags As Long, lpdwConnection As Long, ByVal dwReserved As Long) As Long
    '       Returns   ERROR_SUCCESS if successfull or one of the following error codes
    '                 ERROR_INVALID_PARAMETER - one or more parameters are incorrect
    '                 ERROR_NO_CONNECTION - There is a problem with the dial-up connection
    '                 ERROR_USER_DISCONNECTION - The user clicked either the work offline or cancel button on the dialog box
Private Declare Function InternetHangUp Lib "wininet.dll" (ByVal dwConnection As Long, ByVal dwReserved As Long) As Long
    '       Returns   ERROR_SUCCESS if successfull or an error value otherwise
'   Flags for InternetAutodial
Private Const INTERNET_AUTODIAL_FORCE_ONLINE = &H1
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = &H2
Private Const INTERNET_AUTODIAL_FAILIFSECURITYCHECK = &H4
'   Flags for InternetDial - must not conflict with InternetAutodial flags
'                          as they are valid here also.
Private Const INTERNET_DIAL_FORCE_PROMPT = &H2000
Private Const INTERNET_DIAL_SHOW_OFFLINE = &H4000
Private Const INTERNET_DIAL_UNATTENDED = &H8000

'   Windows error constants used by all sub's
Private Const ERROR_SUCCESS As Long = 0&
Private Const ERROR_INVALID_PARAMETER = 87&
'   RAS error constants
Private Const RASBASE As Long = 600& 'not sure about this couldn't find raserror.h anywhere on MSDN so
                                     'best-guessed the value based on return code of 631 for cancel button
Private Const ERROR_NO_CONNECTION = (RASBASE + 68&)
Private Const ERROR_USER_DISCONNECTION = (RASBASE + 31&)

'   Events for this module
Public Event ConnectionMade()
Public Event ConnectionClosed()
'
'


Private Sub Class_Initialize()
    mlConnectionNumber = 0&
    mbDisconnectOnTerminate = False
End Sub
Private Sub Class_Terminate()
    If mbDisconnectOnTerminate And mlConnectionNumber <> 0 Then
        Call InternetHangUp(mlConnectionNumber, 0&)
    End If
End Sub
Public Property Get Connected() As Boolean
    Connected = ActiveConnection()
End Property
Public Property Get DisconnectOnTerminate() As Boolean
    DisconnectOnTerminate = mbDisconnectOnTerminate
End Property
Public Property Let DisconnectOnTerminate(ByVal bValue As Boolean)
    mbDisconnectOnTerminate = bValue
End Property
Public Function HangUp() As Long
    If mlConnectionNumber = 0 Then
        HangUp = -1 'no connection from this module
    Else
        HangUp = InternetHangUp(mlConnectionNumber, 0&)
        mlConnectionNumber = 0&
        RaiseEvent ConnectionClosed
    End If
End Function
Public Sub ListDUNs(sDunList() As String)
    Dim plSize As Long
    Dim plEntries As Long
    Dim psConName As String
    Dim plIndex As Long
    Dim RAS(255) As RAS_ENTRIES

    Erase sDunList()
    RAS(0).dwSize = 264
    plSize = 256 * RAS(0).dwSize
    Call RasEnumEntriesA(vbNullString, vbNullString, RAS(0), plSize, plEntries)
    plEntries = plEntries - 1
    If plEntries >= 0 Then
        ReDim sDunList(plEntries)
        For plIndex = 0 To plEntries
            psConName = StrConv(RAS(plIndex).szEntryname(), vbUnicode)
            sDunList(plIndex) = Left$(psConName, InStr(psConName, vbNullChar) - 1)
        Next plIndex
    End If
End Sub
Public Function StartDUN(hWnd As Long, sDUN As String) As Long
    Dim plResult As Long

    If mlConnectionNumber <> 0 And ActiveConnection() Then
        StartDUN = -1   'already issued a connection
    Else
        plResult = InternetDial(hWnd, sDUN, INTERNET_AUTODIAL_FORCE_UNATTENDED, mlConnectionNumber, 0&)
        If plResult = ERROR_SUCCESS Then
            RaiseEvent ConnectionMade
        Else
            mlConnectionNumber = 0 'somethings amiss, clear connection #
        End If
        StartDUN = plResult
    End If
End Function

'   Module support routines
'======================================================================================
Private Function ActiveConnection() As Boolean
   Dim hKey As Long
   Dim lpData As Long
   Dim nSizeData As Long

  'function checks registry for an active connection
   Const sSubKey = "SystemCurrentControlSetServicesRemoteAccess"
   Const sKeyValue = "Remote Connection"
   'default false
   ActiveConnection = False
   If RegOpenKey(HKEY_LOCAL_MACHINE, sSubKey, hKey) = ERROR_SUCCESS Then
      lpData = 0&
      nSizeData = Len(lpData)
      If RegQueryValueEx(hKey, sKeyValue, 0&, 0&, lpData, nSizeData) = ERROR_SUCCESS Then
         ActiveConnection = lpData <> 0
      End If
      Call RegCloseKey(hKey)
   End If
End Function

وبالنسبة للكود السابق فالذي أعرفه أن حده إنشاء اسم للإتصال مع بعض الخيارات الأخرى كرقم الهاتف وغيرها أما كلمة السر واسم المستخدم فلا أعرف كيففية تسجيلهما للمستخدم .

ولك تحياتي

ايه الطول ده كله:'(

انا مش فاهم حاجة الكود يدوخ :blink:

ممكن تفصيل