frmdialupmanage.frm

adsl拨号工具 有很多功能 不错啊 大家试试

    Case RASCS_PASSEXPIRED: '4099
        Label13.Caption = "密码已过期..."
        Debug.Print Label13
    Case RASCS_CONNECTED: '8192
        Label13.Caption = "已经建立连接..."
        StartTime = Format(Now, "yyyy/mm/dd hh:mm:ss")
        Label16 = StartTime
        lblType.Caption = rasDialer.DeviceType
        Label28 = rasDialer.InternetAddress
        Label19 = rasDialer.ConnectSpeed
        Label31 = rasDialer.BytesIn & "kbps"
        Label32 = rasDialer.BytesOut & "kbps"
        Timer1.Enabled = True
        Debug.Print Label13
    Case RASCS_DISCONNECTED: '8193
        Label13.Caption = "连接已经断开..."
        Debug.Print Label13
        EndTime = Format(Now, "yyyy/mm/dd hh:mm:ss")
        Label17 = EndTime
        
    Case RASCS_UNUSED:  '-1
        Label13.Caption = "没有联接建立..."
        Debug.Print Label13
        EndTime = Format(Now, "yyyy/mm/dd hh:mm:ss")
        Label17 = EndTime
    End Select

'-1 RAS_UNUSED No connection has been established
'0 RAS_OPENPORT The communications port is about to be opened
'1 RAS_PORTOPENED The communications port has been opened
'2 RAS_CONNECTDEV A device is about to be connected.
'3 RAS_DEVCONNECTED A device has been connected successfully
'4 RAS_ALLDEVCONNECTED    All devices in the device chain have been connected. At this point, the physical link is established.
'5 RAS_AUTHENTICATE The user authentication process is starting
'10 RAS_AUTHPROJECT The projection phase is starting. (That is, protocol-specific information is being requested.)
'14 RAS_AUTHENTICATED The user has been authenticated
'15 RAS_PREPCALLBACK The line is about to be disconnected in preparation for callback
'16 RAS_MODEMRESET The modem is resetting itself in preparation for callback
'17 RAS_WAITFORCALL Waiting for callback from remote server
'18 RAS_PROJECTED Protocol specific information has been negotiated
'4096 RAS_PAUSED Dialer paused for interactive login
'4097 RAS_RETRYAUTH Retrying user authentication
'4098 RAS_CALLBACK Callback has been set by caller
'4099 RAS_PASSEXPIRED Password has expired
'8192 RAS_CONNECTED The connection has been established
'8193 RAS_DISCONNECTED The connection has been terminated

'-1 RAS_UNUSED 没有连接被建立
'0 RAS_OPENPORT 沟通港口是有关到被打开
'1 RAS_PORTOPENED 沟通港口已经被打开
'2 RAS_CONNECTDEV 一装置是有关到被连接。
'3 RAS_DEVCONNECTED 一装置成功地已经被连接
'4 RAS_ALLDEVCONNECTED 装置链的所有装置已经被连接。 此时，实际的联编被建立。
'5 RAS_AUTHENTICATE 使用者证明程序正在开始
'10 RAS_AUTHPROJECT 发射时期正在开始。 ( 是,记录- 特性数据正在被请求)。
'14 RAS_AUTHENTICATED 使用者已经被证明
'15 RAS_PREPCALLBACK 线是有关到为收回在准备中被分离
'16 RAS_MODEMRESET 调制解调器正在为收回在准备中重新设定它本身
'17 RAS_WAITFORCALL 等候来自遥远的伺候器的收回
'18 RAS_PROJECTED 记录特性数据已经被商议
'4096 RAS_PAUSED 拨号器为交谈式登录暂停
'4097 RAS_RETRYAUTH 再试使用者证明
'4098 RAS_CALLBACK 收回藉着来电者已经是放置
'4099 RAS_PASSEXPIRED 密码已经期满
'8192 RAS_CONNECTED 连接已经被建立
'8193 RAS_DISCONNECTED 连接已经被结束



'RASCS_UNUSED = -1 '控制在使用中是不
'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 '联编正要为一个收回在 preperation 中分离
'RASCS_WAITFORMODEMRESET = 16 '客户正在等候调制解调器重新设定
'RASCS_WAITFORCALLBACK = 17 '客户正在等候一个收入收回
'RASCS_PROJECTED = 18 '发射时期已经完成

'RASCS_CONNECTED = 8192 '一个成功的连接已经被建立
'RASCS_DISCONNECTED = 8193 ' 客户已经被分离或连接尝试失败的
End Sub

Private Sub rasDialer_Timeout()
    rasDialer.Disconnect
    Label13.Caption = "无法连接到" & rasDialer.PhoneEntry
    UpDateInfo
End Sub

Private Sub Text1_Change()
   If Len(Trim(Text1)) <> 0 Then
      Command6.Enabled = True
   Else
      Command6.Enabled = False
   End If
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
   If KeyAscii = 22 Then KeyAscii = 0
   If KeyAscii = 13 Then
      Text2.Enabled = True
      Text2.SetFocus
   End If
End Sub

Private Sub Text2_Change()
   If Len(Trim(Text2)) <> 0 Then
      Command1.Enabled = True
   Else
      Command1.Enabled = False
   End If
End Sub

'保存上网信息
Sub RecoreWork()
  On Error Resume Next
  Open IIf(Right(App.Path, 1) = "\", App.Path & "RecordDialList", App.Path & "\RecordDialList") For Append As #1
  Print #1, Left(Trim(DialUser) & Space(8), 8 - Checkstr(Trim(DialUser))) _
   & "  " & Left(Trim(Combo1) & Space(30), 30 - Checkstr(Trim(Combo1))) _
   & "  " & Left(Trim(Replace(Text2, vbCrLf, "")) & Space(30), 30 - Checkstr(Trim(Replace(Text2, vbCrLf, "")))) _
   & "  " & Left(Trim(Format(StartTime, "yyyy/mm/dd hh:mm:ss")) & Space(19), 19 - Checkstr(Trim(Format(StartTime, "yyyy/mm/dd hh:mm:ss")))) _
   & "  " & IIf(Len(EndTime) = 0, Left(Trim(Format(Now, "yyyy/mm/dd hh:mm:ss")) & Space(19), 19 - Checkstr(Trim(Format(Now, "yyyy/mm/dd hh:mm:ss")))), Left(Trim(Format(EndTime, "yyyy/mm/dd hh:mm:ss")) & Space(19), 19 - Checkstr(Trim(Format(EndTime, "yyyy/mm/dd hh:mm:ss"))))) _
   & "  用时:" & Left(Trim(Format(CDate(StartTime) - CDate(EndTime), "hh时mm分ss秒")) & Space(19), 19 - Checkstr(Trim(Format(CDate(StartTime) - CDate(EndTime), "hh时mm分ss秒"))))
  Close #1
  Label10 = Format(CDate(StartTime) - CDate(EndTime), "hh时mm分ss秒")  ' Left(Trim(Time_Span(StartTime, EndTime)) & Space(19), 19 - Checkstr(Trim(Time_Span(StartTime, EndTime))))
  StartTime = 0
  EndTime = 0
  Label16 = ""
  Label17 = ""
  List1.Enabled = True
  Text2 = ""
  
  '?DateDiff("d", date1, date2)  天数相减
  'cdate(cdate(format(now(),"hh:nn:ss")) - #21:18:12#)
  'cdate(#9:30:11# - #1:20:13#)
End Sub

'保存拨号不成功信息
Sub RecoreErr(ErrInfo As String)
    On Error Resume Next
    Open IIf(Right(App.Path, 1) = "\", App.Path & "RecordError.Txt", App.Path & "\RecordError.Txt") For Append As #1
  '  Print #1, Left(Trim(DialUser) & Space(8), 8 - Checkstr(Trim(DialUser))) & "   " & Combo1.Text & "        " & Left(Trim(Text2) & Space(30), 30 - Checkstr(Trim(Text2))) & "     " & ErrInfo
    Close #1
End Sub

Private Sub MaskMenu(ByVal oText As TextBox)
    With oText
        .Enabled = False
        .Enabled = True
        .SetFocus
        SendKeys "%"
    End With
End Sub

Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 93 Then MaskMenu Text1
End Sub

Private Sub Text1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then MaskMenu Text1
End Sub

Sub UpDateInfo()
    If rasDialer.State = RASCS_UNUSED Then
        Label13 = "未在线！"
        Command1.Enabled = True
        List1.Enabled = True
        Combo1.Enabled = True
        Text1.Enabled = True
        Text2.Enabled = True
        Text3.Enabled = True
        Text4.Enabled = True
        Command6.Enabled = True
        Command2.Enabled = True
        If rasDialer.PhoneBookEntries > 0 And Len(Text3.Text) > 0 And _
            Len(Text4.Text) > 0 Then
            Command1.Enabled = True
            Command1.Caption = "连接上网(&D)"
        Else
            Command1.Enabled = False
            Command1.Caption = "连接上网(&D)"
        End If
    Else
        Combo1.Enabled = False
        Text1.Enabled = False
        Text2.Enabled = False
        Text3.Enabled = False
        Text4.Enabled = False
        List1.Enabled = False
        Command6.Enabled = False
        Command2.Enabled = False
        If rasDialer.Connected Then
           Command1.Enabled = True
           Command1.Caption = "断线下网(&H)"
           StartTime = Format(Now, "yyyy/mm/dd hh:mm:ss")
           Label16 = StartTime
           lblType.Caption = rasDialer.DeviceType
           '拨号后是否暂停一会然后缩到托盘
           'Sleep (1500)
           'WindowState = vbMinimized
           'hyperjump = ShellExecute(0&, vbNullString, "http://www.china-huahang.com/main.shtml", vbNullString, vbNullString, vbNormalFocus)
           'hyperjump = ShellExecute(0&, vbNullString, Text8, vbNullString, vbNullString, vbNormalFocus)
           '是否启动流量计
        Else
            Command1.Enabled = True
            Command1.Caption = "取消拨号(&C)"
            Label13 = "未在线!"
        End If
    End If

End Sub

Private Sub Text2_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
       Call Command1_Click
    End If
End Sub

'更新状态信息：托盘灯、信息接收发送状态
Private Sub Timer1_Timer()
    On Error Resume Next
    Call UpdateInterfaceInfo
End Sub

'更新状态信息：托盘灯、信息接收发送状态子程序
Private Sub UpdateInterfaceInfo()
    On Error Resume Next
    Dim objInterface        As CInterface
    Static st_objInterface  As CInterface
    Static lngBytesRecv     As Double
    Static lngBytesSent     As Double
    Dim blnIsRecv           As Boolean
    Dim blnIsSent           As Boolean
    If st_objInterface Is Nothing Then Set st_objInterface = New CInterface
    Set objInterface = m_objIpHelper.Interfaces(1)
    Select Case objInterface.InterfaceType
    Case MIB_IF_TYPE_ETHERNET: lblType.Caption = "以太网"  'Ethernet
    Case MIB_IF_TYPE_FDDI: lblType.Caption = "光纤网"   'FDDI
    Case MIB_IF_TYPE_LOOPBACK: lblType.Caption = "环路"   'Loopback
    Case MIB_IF_TYPE_OTHER: lblType.Caption = "其他"
    Case MIB_IF_TYPE_PPP: lblType.Caption = "点点通"
    Case MIB_IF_TYPE_SLIP: lblType.Caption = "串行接口"   'SLIP
    Case MIB_IF_TYPE_TOKENRING: lblType.Caption = "令牌网"     'TokenRing
    End Select
    Label31.Caption = Trim(Format(m_objIpHelper.BytesReceived / 1024, "###,###,###,###,##0"))
    Label32.Caption = Trim(Format(m_objIpHelper.BytesSent / 1024, "###,###,###,###,##0"))
    
    Set st_objInterface = objInterface
    '---------------
    blnIsRecv = (m_objIpHelper.BytesReceived / 1024 > lngBytesRecv / 1024)
    blnIsSent = (m_objIpHelper.BytesSent / 1024 > lngBytesSent / 1024)
    Label24 = rasDialer.BytesIn & "kbps"
    Label23 = rasDialer.BytesOut & "kbps"
    lblType.Caption = rasDialer.DeviceType
    Label28 = rasDialer.InternetAddress
    Label19 = rasDialer.ConnectSpeed
    If rasDialer.Connected Then
      Label13 = "已在线!"
    Else
      Label13 = "未在线!"
    End If
    If blnIsRecv And blnIsSent Then
    Pic1.Picture = Image2(3).Picture
    Me.Icon = Image2(3).Picture
    Image1.Picture = Image4(3).Picture
    ElseIf (Not blnIsRecv) And blnIsSent Then
    Pic1.Picture = Image2(1).Picture
    Me.Icon = Image2(1).Picture
    Image1.Picture = Image4(1).Picture
    ElseIf blnIsRecv And (Not blnIsSent) Then
    Pic1.Picture = Image2(2).Picture
    Me.Icon = Image2(2).Picture
    Image1.Picture = Image4(2).Picture
    ElseIf Not (blnIsRecv And blnIsSent) Then
    Pic1.Picture = Image2(0).Picture
    Me.Icon = Image2(0).Picture
    Image1.Picture = Image4(0).Picture
    End If
    If rasDialer.Connected Then
       Label10.Caption = Format(CDate(StartTime) - CDate(Now), "hh时mm分ss秒")
    End If
    
    ModifyIcon
    lngBytesRecv = m_objIpHelper.BytesReceived
    lngBytesSent = m_objIpHelper.BytesSent
    DoEvents
    
End Sub

'更改托盘图标及信息
Function ModifyIcon()
    TheForm.cbSize = Len(TheForm)
    
    TheForm.mhWnd = Pic1.hwnd
    TheForm.hIcon = Pic1.Picture
    TheForm.uID = 1&
    
    TheForm.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    
    TheForm.uCallbackMessage = WM_MOUSEMOVE
    If rasDialer.Connected Then
       TheForm.szTip = List1.Text & "当前已在线!" & Chr(13) & "已运行" & Format(CDate(StartTime) - CDate(Now), "hh时mm分ss秒") & vbNullChar
    End If
    Shell_NotifyIcon NIM_MODIFY, TheForm
End Function

'增加图标到托盘
Public Function SysTray()
    TheForm.cbSize = Len(TheForm)
    
    TheForm.mhWnd = Pic1.hwnd
    TheForm.hIcon = Pic1.Picture
    TheForm.uID = 1&
    
    TheForm.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
    
    TheForm.uCallbackMessage = WM_MOUSEMOVE
    
    TheForm.szTip = ProgTitle & App.Major & "." & App.Minor & "." & App.Revision & Chr(13) & " 当前未在线!" & vbNullChar
    
    Shell_NotifyIcon NIM_ADD, TheForm
End Function

'删除托盘图标
Public Sub CleanUpSystray()
    Shell_NotifyIcon NIM_DELETE, TheForm
End Sub

'托盘鼠标事件
Private Sub Pic1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static Rec As Boolean, MSG As Long
    MSG = X / Screen.TwipsPerPixelX
    If Rec = False Then
        Rec = True
        Select Case MSG
            Case WM_LBUTTONDBLCLK:     '鼠标左键双击
                 Me.WindowState = vbNormal
                 Me.Show
                 App.TaskVisible = True
            Case WM_LBUTTONDOWN:

            Case WM_LBUTTONUP:         '鼠标左键单击
            Case WM_RBUTTONDBLCLK:     '鼠标右键单击
            Case WM_RBUTTONDOWN:
            Case WM_RBUTTONUP:
                 MenuTrack Me          '弹出菜单
        End Select
        Rec = False
    End If
End Sub