frmdialupmanage.frm

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

End Sub

'拨号上网
Private Sub Command1_Click()
    Dim Temp As Long
    Dim nError As Integer
    If rasDialer.State = RASCS_UNUSED Then
        If List1.Text = "" Then
           Alert Me, MsgBox1, DeyAmn
           List1.SetFocus
           Exit Sub
        End If
        '校验密码
        If Trim(Text1) <> selestr(QueryValue(hKey, SetKeyPropertyA, "WatchWord" & Trim(sTR(List1.ListIndex)))) Then
             Alert Me, MsgBox2, DeyAmn
             Text1.SelStart = 0
             Text1.SelLength = Len(Text1.Text)
             Text1.SetFocus
             Exit Sub
        End If
        '校验工作内容
        If Len(Text2) = 0 Then
           Alert Me, MsgBox3, DeyAmn
           Text2.SelStart = 0
           Text2.SelLength = Len(Text2.Text)
           Text2.SetFocus
           Exit Sub
        End If
        
        If Checkstr(Text2) = 0 Then
           Alert Me, MsgBox4, DeyAmn
           Text2.SelStart = 0
           Text2.SelLength = Len(Text2.Text)
           Text2.SetFocus
           Exit Sub
        End If
        If LenB(Text2) < 6 Then
           Alert Me, MsgBox5, DeyAmn
           Text2.SelStart = 0
           Text2.SelLength = Len(Text2.Text)
           Text2.SetFocus
           Exit Sub
        End If
        If Combo1.Text = "" Or Text3.Text = "" Or Text4.Text = "" Then
           Temp = MsgBox("您没有输入有效的拨号网络参数!若您是超级用户请到系统设置中设置!", vbExclamation, "错误")
           Exit Sub
        End If
        With rasDialer
            '.PhoneNumber = "0"
            .UserName = Trim(Text3.Text)
            .Password = Trim(Text4.Text)
            '.UserDomain = ""
            nError = .Connect()
            If nError <> 0 Then
               MsgBox "无法连接到" & .PhoneEntry, vbExclamation, App.Title
               Exit Sub
            End If
        End With
        UpDateInfo
    Else  '断开
        Call HangUpNet
        UpDateInfo
    End If
End Sub

Sub HangUpNet()
   Dim nError As Integer
   If rasDialer.Connected Then
      Label13 = "正在断开连接..."
      DoEvents
      nError = rasDialer.Disconnect()
      Label17 = Format(Now, "yyyy/mm/dd hh:mm:ss")
      Label13 = "已断开!"
      WindowState = 0
      ' Call HangUp
      ' Call RemoveConnection(hconn)
      Call RecoreWork
      Command2.Enabled = False
      Text1 = ""
      List1.Enabled = True
      Text2.Enabled = True
      Text2 = ""
   End If
End Sub



Private Sub Command10_Click()

End Sub

'帮助
Private Sub Command4_Click()
    MsgBox "1.选择用户列表中您的名称,如果没有请告诉我给您加入." & Chr(10) & Chr(13) & "2.再输入您的密码和上网内容." & Chr(10) & Chr(13) & "3.点击拨号上网按钮即可" & Chr(10) & Chr(13) & "4.注意:您不使用时请一定退出程序或单击断线下网按钮,以免程序记录您上网的时间太长,造成误会." & Chr(10) & Chr(13) & "5.请注意修改和保密您的密码,别人使用可别怪我,谢谢!", vbInformation, "注意"
End Sub

'查看记录
Private Sub Command3_Click()
   FrmViewRecord.Show vbModal
End Sub

'修改密码
Private Sub Command6_Click()
    If List1.SelCount = 0 Then
       MsgBox "请选择您的名称！", vbCritical, "提示"
       Exit Sub
    End If
    If Trim(Text1) <> selestr(QueryValue(hKey, SetKeyPropertyA, "WatchWord" & Trim(sTR(List1.ListIndex)))) Then
       Alert Me, MsgBox6, DeyAmn
       Text1.SelStart = 0
       Text1.SelLength = Len(Text1.Text)
       Text1.SetFocus
       Exit Sub
    End If
    frmEditPassWord.Show vbModal
End Sub

'系统参数设置
Private Sub Command2_Click()
   Call Sett
End Sub

Sub Sett()
   If selestr(QueryValue(hKey, SetKeyPropertyA, "level" & Trim(sTR(List1.ListIndex)))) <> "SuperManage" Then
      MsgBox "呵呵,您是没有超级管理权限的,要想获取此权限,那就向管理员申请吧!", vbCritical, ProgTitle
      Exit Sub
   Else
      If Trim(Text1) = "" Then
         MsgBox "虽然你是超级管理员也要输入密码哎!", vbCritical, ProgTitle
         Text1.SelStart = 0
         Text1.SelLength = Len(Text1.Text)
         Text1.SetFocus
         Exit Sub
      End If
      If Trim(Text1) <> selestr(QueryValue(hKey, SetKeyPropertyA, "WatchWord" & Trim(sTR(List1.ListIndex)))) Then
         MsgBox "这好像不是您的密码哎,仔细想想!", vbCritical, ProgTitle
         Text1.SelStart = 0
         Text1.SelLength = Len(Text1.Text)
         Text1.SetFocus
         Exit Sub
      Else
         FrmSettings.Show vbModal
      End If
   End If

End Sub
Private Sub Command5_Click()
  Timer1.Enabled = False
  DoEvents
  Unload Me
  Set frmDialupManage = Nothing
End Sub

Private Sub Form_Load()
  DoEvents
  Me.Caption = ProgTitle & " Version " & App.Major & "." & App.Minor   ' & " 当前未在线!"
  Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
  If App.PrevInstance Then
     MsgBox ("程序已经运行，不能再次装载！"), vbExclamation, "警告！"
     Unload Me
     End
  End If
  
  #If Win32 Then
      rasDialer.AutoUpdate = True
  #End If
  rasDialer.AutoDisconnect = False

  For nEntry = 0 To rasDialer.PhoneBookEntries - 1
      Combo1.List(nEntry) = rasDialer.PhoneBookEntry(nEntry)
  Next

  If rasDialer.PhoneBookEntries > 0 Then
     Combo1.ListIndex = 0
  End If
  
  
  If Val(QueryValue(hKey, "Software\Mndsoft", "IsSetting")) = 1 Then
      Dim I As Integer
     '若有ini则加载其中参数
     '加载用户名
     For I = 0 To QueryValue(hKey, CreateKeyA, "DialUserTotal")
         List1.AddItem conv_str(QueryValue(hKey, SetKeyPropertyA, "username" & Trim(sTR(I))))
     Next
     
     'IE安全权限
     '删除菜单项
     If Val(QueryValue(hKey, SetKeyPropertyC, "DelStatrMenu")) = 1 Then
'        Check4.Value = 1
     Else
'        Check4.Value = 0
     End If
    
    '禁止IE连接选项
     If Val(QueryValue(hKey, SetKeyPropertyC, "ConnectOption")) = 1 Then
'        Check6.Value = 1
     Else
'        Check6.Value = 0
     End If
    
    '禁用INTERNET向导
     If Val(QueryValue(hKey, SetKeyPropertyC, "IEWizards")) = 1 Then
'        Check5.Value = 1
     Else
'        Check5.Value = 0
     End If
     
     '自动运行网址
     If Val(QueryValue(hKey, SetKeyPropertyC, "Isdefault")) = 1 Then
'        Text8 = "http://www.china-huahang.com/main.shtml"
'        Check2.Value = 1
'        Text8.Enabled = False
     Else
'        Text8 = selestr(QueryValue(hKey, SetKeyPropertyC, "UrlAddress"))
'        Text8.Enabled = True
'        Check2.Value = 0
     End If
     '流量计
     If Val(QueryValue(hKey, SetKeyPropertyC, "DiapMeter")) = 1 Then
'        Check3.Value = 1
     Else
'        Check3.Value = 0
     End If
     
  Else
     MsgBox "在使用本系统之前,请进行增加用户或其他参数设置！", vbInformation, ProgTitle
     FrmSettings.Show vbModal
  End If
  Command1.Enabled = False
  Set m_objIpHelper = New CIpHelper
  Label27 = GetIPAddress
  SysTray
  DoEvents


  If FileExists(IIf(Right(App.Path, 1) = "\", App.Path & "RecordDialList", App.Path & "\RecordDialList")) = False Then
     Open IIf(Right(App.Path, 1) = "\", App.Path & "RecordDialList", App.Path & "\RecordDialList") For Append As #1
     Print #1, "上网管理器记录列表 起始于:" & Now
     Print #1, "======================================================"
     Print #1, "是谁上网 上网类型                          工作内容                       开始时间               结束时间          上网状态"
     Print #1, "------------------------------------------------------------------------------------------------------------------------------------"
     Close #1
  End If
  If FileExists(IIf(Right(App.Path, 1) = "\", App.Path & "RecordError.Txt", App.Path & "\RecordError.Txt")) = False Then
     Open IIf(Right(App.Path, 1) = "\", App.Path & "RecordError.Txt", App.Path & "\RecordError.Txt") For Append As #1
     Print #1, "上网管理器错误记录列表 起始于:" & Now
     Print #1, "======================================================"
     Print #1, "是谁上网   上网类型     工作内容                       时间            状态"
     Print #1, "--------------------------------------------------------------------------------"
     Close #1
  End If
 ' Timer1.Enabled = False
  StartTime = 0
  UpDateInfo
  Hook Me    'FormHook Hook()

End Sub

Private Sub Form_Resize()
  On Error Resume Next
  'Me.Height = 5355
  Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
  If WindowState <> vbMinimized Then
     WindowState = 0
     MenuPopUp
  Else
     MenuPopUp
     Me.Hide
     Alert Me, MsgBox7, DeyAmn
  End If
  'LastState = WindowState
  On Error GoTo 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
  UnHook     'FormHook UnHook()
  DestroyMenu hMenu
  If rasDialer.Connected Then
     Call HangUpNet
  End If
  Call CleanUpSystray
  DoEvents
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 2 Then
        MenuTrack Me 'PopMenu MenuTrack()
    End If
End Sub

Private Sub List1_Click()
    If List1.SelCount > 0 Then
       DialUser = IIf(Len(Trim(List1.Text)) = 0, "未知", Trim(List1.Text))
     End If
     Text1.SetFocus
End Sub

Private Sub rasDialer_Connect()
    Label13.Caption = "已在线!"
    MenuPopUp
    UpDateInfo
End Sub

Private Sub rasDialer_Disconnect()
    Label13.Caption = "未在线!"
    MenuPopUp
    UpDateInfo
End Sub

Private Sub rasDialer_LastError(ErrorCode As Integer, ErrorString As String, Response As Integer)
    rasDialer.Disconnect
    Label13.Caption = ErrorString
    Alert Me, ErrorString, DeyAmn
    UpDateInfo
End Sub

Private Sub rasDialer_Status(State As Integer)
    'Status event generated when dialing state changes
    'This is meant to indicate the progress during the dialing operation
    Select Case rasDialer.State
    Case RASCS_OPENPORT:  '0
       Label13.Caption = "正打开端口" & rasDialer.PhoneEntry & "..."
        Debug.Print Label13
    Case 1 ' RASCS_PORTOPENED:  '1
        Label13.Caption = "端口已打开成功" & rasDialer.PhoneEntry & "..."
        Debug.Print Label13
    Case 2  'RASCS_CONNECTDEV:  '2
        Label13.Caption = "正打开设备" & rasDialer.PhoneEntry & "..."
        Debug.Print Label13
    Case 3  'RASCS_DEVCONNECTED '3
        Label13.Caption = "设备已打开成功" & rasDialer.PhoneEntry & "..."
        Debug.Print Label13
    Case 4   'RASCS_ALLDEVCONNECTED: '4
        Label13.Caption = "所有设备已建立联编..."
        Debug.Print Label13
    Case 5 'RASCS_AUTHENTICATE '5
        Label13.Caption = "正在验证用户名和密码..."
        Debug.Print Label13
    Case 6  'RASCS_AUTHPROJECT: '10
        Label13.Caption = "发射时期正在开始。 ( 是,记录- 特性数据正在被请求)10..."
        Debug.Print Label13
    Case 7   'RASCS_AUTHENTICATED: '14
        Label13.Caption = "验证通过..."
        Debug.Print Label13
    Case RASCS_PREPAREFORCALLBACK: '15  RASCS_PREPCALLBACK
        Label13.Caption = "联编正要为一个收回在 preperation 中分离15..."
        Debug.Print Label13
    Case RASCS_WAITFORMODEMRESET: '16 RASCS_MODEMRESET
        Label13.Caption = "客户正在等候调制解调器重新设定16..."
        Debug.Print Label13
    Case RASCS_WAITFORCALLBACK: '17
        Label13.Caption = "正在等待远方服务器回应..."
        Debug.Print Label13
    Case RASCS_PROJECTED: '18
        Label13.Caption = "发射时期已经完成18"
        Debug.Print Label13
    Case RASCS_PAUSED: '4096
        Label13.Caption = "登陆暂停..."
        Debug.Print Label13
    Case RASCS_RETRYAUTH: '4097
        Label13.Caption = "再次验证..."
        Debug.Print Label13
    Case RASCS_CALLBACK: '4098
        Label13.Caption = "收回藉着来电者已经是放置4098..."
        Debug.Print Label13