VB中RASDIAL异步调用,还未验证

'****************************************************************************** 

'取得目前连线信息 
  '       Function   GetAllConnects(ConnEntry()   As   RASCONN)   As   Long 
'传回值:                 总共连线数 
'使用方式: 
      '         Dim   Conn()   As   RASCONN 
    '           Dim   icnt   As   Long 
  '             icnt   =   GetAllConnects(Conn()) 


'取得所有拨号网络Entry的资讯   (不管有没有连线) 
  '       Function   GetRasNameEntries(Entry()   As   RASENTRYNAME,   _ 
                                                              Optional   PhonePath   As   String)   As   Long 
'传回值:     总共Entry数 
'使用方式: 
      '         Dim   Conn()   As   RASENTRYNAME 
    '           Dim   icnt   As   Long 
  '             icnt   =   GetRasNameEntries(Conn()) 

'呼叫修改某一个连线Entry   的Window 
  '       Sub   EditEntry(ByVal   EntryName   As   String,   _ 
                                    Optional   ByVal   PhonePath   As   String) 
'在拨号网络中新增一个Entry 
  '       Sub   CreateEntry(Optional   ByVal   PhonePath   As   String) 
'自动拨接 
      '   Function   DialUp(ByVal   EntryName   As   String,   ByVal   UserN   As   String,   _ 
                    ByVal   Pwd   As   String,   Optional   ByVal   PhonePath   As   String)   As   Long 
'取消拨接 
      '     Function   HangUp(ByVal   hconn   As   Long)   As   Boolean 
  '             hconn的值来自於 
    '           1.DialUp()的传回值 
  '             2.GetAllConnects()   RASCONN结构叁数中的hRasConn值 

'取得连线状态 
'           Function   GetConnectStatus(ByVal   hocnn   As   Long)   As   Long 
'               hconn的值来自於 
'               1.DialUp()的传回值 
'               2.GetAllConnects()   RASCONN结构叁数中的hRasConn值 

'****************************************************************************** 
Option   Explicit 
Public   Const   RAS_MaxEntryName   =   256 
Public   Const   RAS_MaxDeviceName   =   128 
Public   Const   RAS_MaxDeviceType   =   16 
Public   Const   RAS_MaxPhoneNumber   =   128 
Public   Const   RAS_MaxCallbackNumber   =   128 
Public   Const   UNLEN   =   256 
Public   Const   PWLEN   =   256 
Public   Const   DNLEN   =   15 
Public   Const   ERROR_INVALID_HANDLE   =   6 

Type   RASCONN 
      dwSize   As   Long   '412 
      hRasConn   As   Long 
      szEntryName(RAS_MaxEntryName)   As   Byte 
      szDeviceType(RAS_MaxDeviceType)   As   Byte 
      szDeviceName(RAS_MaxDeviceName)   As   Byte 
End   Type 

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

Type   RASDIALPARAMS 
    dwSize   As   Long   '1052 
    szEntryName(RAS_MaxEntryName)   As   Byte 
    szPhoneNumber(RAS_MaxPhoneNumber)   As   Byte 
    szCallbackNumber(RAS_MaxCallbackNumber)   As   Byte 
    szUserName(UNLEN)   As   Byte 
    szPassword(PWLEN)   As   Byte 
    szDomain(DNLEN)   As   Byte 
End   Type 

Type   RASCONNSTATUS 
        dwSize   As   Long     '144 
        RasConnState   As   Long 
        dwError   As   Long 
        szDeviceType(RAS_MaxDeviceType)   As   Byte 
        szDeviceName(RAS_MaxDeviceName)   As   Byte 
End   Type 

Declare   Function   RasDial   Lib   "rasapi32 "   _ 
    Alias   "RasDialA "   (DialExt   As   Long,   ByVal   lpPhoneBook   As   String,   _ 
    RasDialParam   As   RASDIALPARAMS,   ByVal   NotifyType   As   Long,   _ 
    ByVal   Notifter   As   Long,   hRasConn   As   Long)   As   Long 
Declare   Function   RasCreatePhonebookEntry   Lib   "rasapi32 "   _ 
    Alias   "RasCreatePhonebookEntryA "   (ByVal   hWnd   As   Long,   ByVal   lpPhoneBook   As   String)   As   Long 
Declare   Function   RasEditPhonebookEntry   Lib   "rasapi32 "   _ 
    Alias   "RasEditPhonebookEntryA "   (ByVal   hWnd   As   Long,   ByVal   lpPhoneBook   As   String,   _ 
    ByVal   lpEntryName   As   String)   As   Long 
Declare   Function   RasGetErrorString   Lib   "rasapi32 "   _ 
    Alias   "RasGetErrorStringA "   (ByVal   ErrValue   As   Long,   ByVal   lpErrStr   As   String,   _ 
    ByVal   cSize   As   Long)   As   Long 
Declare   Function   RasEnumEntries&   Lib   "rasapi32 "   _ 
    Alias   "RasEnumEntriesA "   (ByVal   res   As   String,   ByVal   lpszPhonebook   As   String,   _ 
    lpRasEntryBuffer   As   Any,   lpcb   As   Long,   lpcEntries   As   Long) 
Declare   Function   RasEnumConnections   Lib   "rasapi32 "   Alias   _ 
            "RasEnumConnectionsA "   (lprasconn   As   Any,   _ 
              lpcb   As   Long,   lpConnect   As   Long)   As   Long 
Declare   Function   RasHangUp   Lib   "rasapi32 "   Alias   _ 
            "RasHangUpA "   (ByVal   hRasConn   As   Long)   As   Long 
Declare   Function   RasGetConnectStatus   Lib   "rasapi32 "   Alias   _ 
            "RasGetConnectStatusA "   (ByVal   hRasConn   As   Long,   _ 
            lprasconnstatus   As   RASCONNSTATUS)   As   Long 
Declare   Function   RasGetEntryDialParams   Lib   "rasapi32 "   _ 
      Alias   "RasGetEntryDialParamsA "   (ByVal   lpszPhonebook   As   String,   _ 
      lpRasDialParams   As   RASDIALPARAMS,   _ 
      lpfPassword   As   Byte)   As   Long 

Declare   Sub   Sleep   Lib   "kernel32 "   (ByVal   dwMilliseconds   As   Long) 
Enum   RasConnState 
        RASCS_OpenPort   =   0 
        RASCS_PortOpened                           '1 
        RASCS_ConnectDevice                     '2 
        RASCS_DeviceConnected                 '3 
        RASCS_AllDevicesConnected         '4 
        RASCS_Authenticate                       '5 
        RASCS_AuthNotify                           '6 
        RASCS_AuthRetry   '7 
        RASCS_AuthCallback   '8 
        RASCS_AuthChangePassword   '9 
        RASCS_AuthProject   '10 
        RASCS_AuthLinkSpeed   '11 
        RASCS_AuthAck   '12 
        RASCS_ReAuthenticate   '13 
        RASCS_Authenticated   '14 
        RASCS_PrepareForCallback   '15 
        RASCS_WaitForModemReset   '16 
        RASCS_WaitForCallback   '17 
        RASCS_Projected   '18 
        RASCS_StartAuthentication     '19 
        RASCS_CallbackComplete   '20 
        RASCS_LogonNetwork                   '21 
        RASCS_Interactive   =   &H1000   '4096 
        RASCS_RetryAuthentication   '4097 
        RASCS_CallbackSetByCaller   '4098 
        RASCS_PasswordExpired   '4099 
        RASCS_Connected   =   &H2000   '8192 
        RASCS_Disconnected   '8193 
End   Enum 


'取得目前连线资讯 
Public   Function   GetAllConnections(Conn()   As   RASCONN)   As   Long 
        Dim   dl&,   size&,   validConnection&,   counter% 
        ReDim   Conn(0) 
        Conn(0).dwSize   =   412 
        size   =   412 
        dl&   =   RasEnumConnections(Conn(0),   size,   validConnection) 
        If   validConnection   >   0   Then 
              ReDim   Conn(validConnection   -   1) 
              Conn(0).dwSize   =   412 
              size   =   validConnection   *   412 
              dl&   =   RasEnumConnections(Conn(0),   size,   validConnection) 
        End   If 
        If   dl   =   0   Then 
              GetAllConnections   =   validConnection 
        Else 
              GetAllConnections   =   -1 
        End   If 
End   Function 

'取得所有拨号网路Entry的资讯(不管有没有连线) 
Public   Function   GetRasNameEntries(Entry()   As   RASENTRYNAME,   Optional   PhonePath   As   String)   As   Long 
Dim   di   As   Long,   lpcb   As   Long,   lpentries   As   Long 
Dim   addit   As   Long 
Dim   i   As   Long 
Dim   len5 
di&   =   RasEnumEntries(vbNullString,   PhonePath,   0,   0,   lpentries) 
If   lpentries   >   0   Then 
      i   =   lpentries   -   1 
      ReDim   Entry(i) 
      len5   =   LenB(Entry(0)) 
      addit   =   (4   -   (len5   Mod   4))   Mod   4 
      Entry(0).dwSize   =   len5   +   addit 
      lpcb   =   Entry(0).dwSize   *   (i   +   1) 
      di&   =   RasEnumEntries(vbNullString,   PhonePath,   Entry(0),   lpcb,   lpentries) 
End   If 
If   di   =   0   Then 
      GetRasNameEntries   =   lpentries 
Else 
      GetRasNameEntries   =   -1 
End   If 
End   Function 
'呼叫修改某一个连线Entry   的Window 
Public   Sub   EditEntry(ByVal   EntryName   As   String,   Optional   ByVal   PhonePath   As   String) 
Dim   di   As   Long 
di   =   RasEditPhonebookEntry(0,   PhonePath,   EntryName) 
End   Sub 
'於拨号网路中新增一个Entry 
Public   Sub   CreateEntry(Optional   ByVal   PhonePath   As   String) 
Call   RasCreatePhonebookEntry(0,   PhonePath) 
End   Sub 

'自动拨接(Win95   4,   5   个叁数不传，或为vbNullString) 
Public   Function   DialUp(ByVal   EntryName   As   String,   ByVal   UserN   As   String,   _ 
        ByVal   Pwd   As   String,   Optional   ByVal   PhoneBook   As   String,   Optional   sDomain   As   String)   As   Long 
Dim   RasDialPara   As   RASDIALPARAMS 
Dim   bya()   As   Byte,   di   As   Long 
Dim   len5   As   Long,   i   As   Long 
Dim   hRasConn   As   Long 

len5   =   LenB(RasDialPara) 
i   =   (4   -   (len5   Mod   4))   Mod   4 
RasDialPara.dwSize   =   len5   +   i   '1052 
bya   =   StrConv(EntryName,   vbFromUnicode)   +   ChrB(0) 
Call   CopyByte(RasDialPara.szEntryName,   bya) 

bya   =   StrConv(UserN,   vbFromUnicode)   +   ChrB(0) 
Call   CopyByte(RasDialPara.szUserName,   bya) 

bya   =   StrConv(Pwd,   vbFromUnicode)   +   ChrB(0) 
Call   CopyByte(RasDialPara.szPassword,   bya) 

bya   =   StrConv(sDomain,   vbFromUnicode)   +   ChrB(0) 
Call   CopyByte(RasDialPara.szDomain,   bya) 
'若使用以下CallBack   function的方式，则RasDial()不等连线成功或失败便结束。 
di   =   RasDial(0,   PhoneBook,   RasDialPara,   0,   AddressOf   RasDialFunc,   hRasConn) 

'若第二、三个叁数都是0则，RasDial会等连线成功或失败後才执行下一行指令 
'di   =   RasDial(0,   PhoneBook,   RasDialPara,   0,   0,   hRasConn) 

If   di   =   0   Then 
      DialUp   =   hRasConn 
Else 
      DialUp   =   0 
      Dim   str5   As   String 
      str5   =   String(255,   Chr(0)) 
      Call   RasGetErrorString(di,   str5,   256) 
      MsgBox   Left(str5,   InStr(1,   str5,   Chr(0))   -   1),   vbCritical 
      Call   HangUp(hRasConn) 
      frmRasSet.frameMsg.Visible   =   False 
End   If 
End   Function 

Public   Sub   RasDialFunc(ByVal   unMsg   As   Long,   _ 
                                              ByVal   ConnState   As   Long,   _ 
                                              ByVal   dwError   As   Long) 
Dim   strMsg   As   String 
Select   Case   ConnState 
        Case   0 
                strMsg   =   "正在打开．．． " 
        Case   1 
                strMsg   =   "端口已经打开！ " 
        Case   2 
                strMsg   =   "正在连接设备．．． " 
        Case   3 
                strMsg   =   "设备已经连接 " 
        Case   4 
                strMsg   =   "所有设备已经连接 " 
        Case   5 
                strMsg   =   "正在验证用户名及口令．．． " 
        Case   6 
                strMsg   =   "验证通告．．． " 
        Case   7 
                strMsg   =   "验证重试．．． " 
        Case   8 
                strMsg   =   "验证回叫．．． " 
        Case   9 
                strMsg   =   "验证回叫．．． " 
        Case   10 
                strMsg   =   "验证项目．．． " 
        Case   11 
                strMsg   =   "验证连接速度．．． " 
        Case   12 
                strMsg   =   "验证请求．．． " 
        Case   13 
                strMsg   =   "重新验证．．． " 
        Case   14 
                strMsg   =   "验证完成！ " 
        Case   15 
                strMsg   =   "准备回叫．．． " 
        Case   16 
                strMsg   =   "等待调制解调器复位 " 
        Case   17 
                strMsg   =   "等待回叫．．． " 
        Case   18 
                strMsg   =   "projected " 
        Case   19 
                strMsg   =   "开始鉴定．．． " 
        Case   20 
                strMsg   =   "回叫完成！ " 
        Case   21 
                strMsg   =   "正在登录网络．．． " 
        Case   4096 
                strMsg   =   "连接已经成功！ " 
        Case   4097 
                strMsg   =   "重新鉴定．．． " 
        Case   4098 
                strMsg   =   "设置回叫．．． " 
        Case   4099 
                strMsg   =   "口令错误！ " 
        Case   8192 
                strMsg   =   "已经连接啦！ " 
        Case   8193 
                strMsg   =   "已经断开啦！ " 
End   Select 

frmRasSet.lstMsg.AddItem   strMsg 
frmRasSet.lstMsg.ListIndex   =   frmRasSet.lstMsg.NewIndex 
If   ConnState   =   RASCS_Connected   Or   ConnState   =   RASCS_Interactive   Then 
        'frmRasSet.frameMsg.Visible   =   False 
        Load   frmRemote 
        Unload   frmRasSet 
        frmRemote.Show 
End   If 
If   ConnState   =   RASCS_Disconnected   Then 
        MsgBox   "拨号网络连接失败！ " 
        frmRasSet.frameMsg.Visible   =   False 
End   If 
End   Sub 
'取消拨接 
Public   Function   HangUp(ByVal   hconn   As   Long)   As   Boolean 
Dim   st   As   Long,   len5   As   Long 
Dim   i   As   Long,   ConStatus     As   RASCONNSTATUS 
st   =   RasHangUp(hconn) 
len5   =   LenB(ConStatus) 
i   =   (4   -   (len5   Mod   4))   Mod   4 
ConStatus.dwSize   =   len5   +   i 
Do   While   True 
    Call   Sleep(0) 
    i   =   RasGetConnectStatus(hconn,   ConStatus) 
    If   i   =   ERROR_INVALID_HANDLE   Then 
          Exit   Do 
    End   If 
Loop 
If   st   =   0   Then 
      HangUp   =   True 
Else 
      HangUp   =   False 
End   If 
End   Function 
'取得连线状态 
Public   Function   GetConnectStatus(ByVal   hconn   As   Long)   As   Long 
Dim   i   As   Long,   ConStatus     As   RASCONNSTATUS 
Dim   len5   As   Long 
len5   =   LenB(ConStatus) 
i   =   (4   -   (len5   Mod   4))   Mod   4 
ConStatus.dwSize   =   len5   +   i 
i   =   RasGetConnectStatus(hconn,   ConStatus) 
If   i   =   0   Then 
      GetConnectStatus   =   ConStatus.RasConnState 
Else 
      GetConnectStatus   =   -1 
End   If 
End   Function 
Private   Sub   CopyByte(dest()   As   Byte,   sour()   As   Byte) 
Dim   sourL   As   Long,   sourU   As   Long 
Dim   destL   As   Long,   destU   As   Long,   i   As   Long,   J   As   Long 
sourL   =   LBound(sour) 
sourU   =   UBound(sour) 
destL   =   LBound(dest) 
destU   =   UBound(dest) 
J   =   0 
For   i   =   sourL   To   sourU 
        dest(destL   +   J)   =   sour(i) 
        J   =   J   +   1 
        If   J   > =   (destU   -   destL)   +   1   Then 
              Exit   For 
        End   If 
Next   i 
End   Sub