form1.frm

这里有很多很实用的VB编程案例,方便大家学习VB.

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form Form1 
   Caption         =   "拨号"
   ClientHeight    =   4860
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5835
   LinkTopic       =   "Form1"
   ScaleHeight     =   4860
   ScaleWidth      =   5835
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox txtTerm 
      Height          =   3015
      Left            =   240
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   4
      Top             =   1200
      Width           =   4095
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   5160
      Top             =   240
   End
   Begin VB.CommandButton cmdHangup 
      Caption         =   "Hangup"
      Height          =   495
      Left            =   3000
      TabIndex        =   3
      Top             =   120
      Width           =   1215
   End
   Begin VB.CommandButton cmdDial 
      Caption         =   "Dial"
      Height          =   495
      Left            =   1680
      TabIndex        =   2
      Top             =   120
      Width           =   1215
   End
   Begin VB.TextBox txtPhone 
      Height          =   495
      Left            =   360
      TabIndex        =   0
      Text            =   "2631"
      Top             =   120
      Width           =   1215
   End
   Begin ComctlLib.StatusBar sbrStatus 
      Align           =   2  'Align Bottom
      Height          =   315
      Left            =   0
      TabIndex        =   5
      Top             =   4545
      Width           =   5835
      _ExtentX        =   10292
      _ExtentY        =   556
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   3
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   2
            Object.Width           =   4313
            MinWidth        =   4304
            Text            =   "Status:"
            TextSave        =   "Status:"
            Key             =   "Status"
            Object.Tag             =   ""
            Object.ToolTipText     =   "Communications Port Status"
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   1
            Object.Width           =   1861
            MinWidth        =   882
            Text            =   "Settings:"
            TextSave        =   "Settings:"
            Key             =   "Settings"
            Object.Tag             =   ""
            Object.ToolTipText     =   "Communications Port Settings"
         EndProperty
         BeginProperty Panel3 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   2
            Object.Width           =   3519
            MinWidth        =   3528
            Key             =   "ConnectTime"
            Object.Tag             =   ""
            Object.ToolTipText     =   "Connect Time"
         EndProperty
      EndProperty
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   4440
      Top             =   120
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      CommPort        =   2
      DTREnable       =   -1  'True
      RThreshold      =   1
      RTSEnable       =   -1  'True
   End
   Begin VB.Label lblRetries 
      Height          =   255
      Left            =   360
      TabIndex        =   1
      Top             =   720
      Width           =   3735
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public StartTime
Public CancelNow As Boolean
Public Connected As Boolean
Public Dialing As Boolean
Public EndTime
Private Static Sub ShowData(Term As Control, data As String)
    On Error GoTo Handler
    Const MaxTermSIZE = 16000
    Dim TermSize As Long, i
    
    TermSize = Len(Term.Text)
    If TermSize > MaxTermSIZE Then
       Term.Text = Mid$(Term.Text, 4097)
       TermSize = Len(Term.Text)
    End If

    Term.SelStart = TermSize

    Do
       i = InStr(data, Chr$(10))
       If i Then
          data = Left$(data, i - 1) & Mid$(data, i + 1)
       End If
    Loop While i

    i = 1
    Do
       i = InStr(i, data, Chr$(13))
       If i Then
          data = Left$(data, i) & Chr$(10) & Mid$(data, i + 1)
          i = i + 1
       End If
    Loop While i

    Term.SelText = data
    Term.SelStart = Len(Term.Text)
Exit Sub

Handler:
    MsgBox Error$
    Resume Next
End Sub

Private Sub StartTiming()
    StartTime = Now
    Timer1.Enabled = True
End Sub

Private Sub StopTiming()
    If Timer1.Enabled = True Then
        Timer1.Enabled = False
        sbrStatus.Panels("ConnectTime").Text = ""
        ShowData txtTerm, ("Online time: " & Format(Now - StartTime, "hh:nn:ss") & vbCrLf)
        StartTime = Empty
    End If
End Sub

Public Function ModemWaitResponse(seconds As Integer) As String
    Dim TimeNow As Date
    Dim TimeEnd As Date
    Dim strInput As String
    Dim strTemp As String
    Dim Buffer As Variant
    
    TimeNow = Now()
    TimeEnd = DateAdd("s", seconds, Now())
    strInput = ""
    Do While (Now() < TimeEnd) And (Not CancelNow)
        DoEvents
        If MSComm1.InBufferCount > 0 Then
            Buffer = MSComm1.Input
            strInput = strInput + Buffer
            
            Debug.Print strTemp
            strTemp = CheckForMessage(strInput)
            If strTemp <> "" Then
                ModemWaitResponse = strTemp
                ClearModemBuffer
                Exit Function
            End If
            DoEvents
        End If
    Loop
    ModemWaitResponse = ""
End Function

Private Function CheckForMessage(strTemp As String) As String
    Dim ResponseArray
    Dim Count As Integer
    Dim X As Integer
    
    ResponseArray = Array("OK", "CONNECT", "NO CARRIER", "ERROR", "BUSY", "NO ANSWER", "NO DIAL", "RING")
    Count = UBound(ResponseArray)
    For X = 0 To Count
        If InStr(UCase(strTemp), ResponseArray(X)) Then
            DoEvents
            CheckForMessage = ResponseArray(X)
            ShowData txtTerm, (ResponseArray(X) & vbCrLf)
            
            Exit Function
        End If
    Next X
    CheckForMessage = ""
End Function

Private Function InitializeModem() As Boolean
    Dim strTemp As String
    Dim X As Integer
    sbrStatus.Panels("Status").Text = "Status: Initializing Modem"
    ShowData txtTerm, ("Initializing Modem." & vbCrLf)
    PortOpen
    
    ModemSendLine ("AT Z")
    strTemp = ModemWaitResponse(5)
    
    If CancelNow Then
        InitializeModem = False
        Exit Function
    End If
    
    Select Case strTemp
        Case "OK":
        Case "ERROR":
            sbrStatus.Panels("Status").Text = "Status: Init Modem Error"
            X = Hangup
            InitializeModem = False
            Exit Function
        Case Else
            MsgBox "Uknown modem response"
            Exit Function
    End Select
        
    ModemSendLine ("AT X4 V1 E1 S7=60")
    strTemp = ModemWaitResponse(5)
    
    If CancelNow Then
        InitializeModem = False
        Exit Function
    End If
    
    Select Case strTemp
        Case "OK":
        Case "ERROR":
            sbrStatus.Panels("Status").Text = "Status: Init Modem Error"
            X = Hangup
            InitializeModem = False
            Exit Function
        Case Else
            MsgBox "Uknown modem response"
            Exit Function
    End Select
    sbrStatus.Panels("Status").Text = "Status: Modem initialized"
    InitializeModem = True
End Function

Public Sub ModemSendLine(strText As String)
    PortOpen
    ShowData txtTerm, (strText & vbCrLf)
    MSComm1.Output = strText + vbCrLf
End Sub

Public Sub ClearModemBuffer()
    Dim Buffer As Variant
    Dim X As Integer
    If MSComm1.InBufferCount > 0 Then
        For X = 1 To MSComm1.InBufferCount
            Buffer = MSComm1.Input
            ShowData txtTerm, (Buffer)
        Next X
    End If
End Sub

Private Function Hangup() As Integer
    Dim X As Long
    sbrStatus.Panels("Status").Text = "Disconnecting..."
    If (MSComm1.PortOpen = True) Then
        MSComm1.PortOpen = False
        MSComm1.DTREnable = False
    End If
    
    If (Connected = True) Or (Dialing = True) Then
        For X = 1 To 200000
            DoEvents
        Next X
    End If
    
    sbrStatus.Panels("Settings").Text = "Settings: "
    StopTiming
    sbrStatus.Panels("Status").Text = "Status: "
    Hangup = 0
End Function

Private Sub PortOpen()
    On Error Resume Next
    If Not MSComm1.PortOpen Then
        MSComm1.PortOpen = True
    End If
    
    If MSComm1.PortOpen Then
        sbrStatus.Panels("Settings").Text = "Settings: " & MSComm1.Settings
    Else
        sbrStatus.Panels("Settings").Text = "Settings: "
        StopTiming
    End If
End Sub

Private Sub cmdDial_Click()
    Dim strTemp As String
    Dim Retries As Integer
    Dim X As Integer
    
    Retries = 3
    CancelNow = False
    Dialing = True
    Do While Retries >= 0 And (Not CancelNow)
        sbrStatus.Panels("Status").Text = "Status: Dialing..."
        ModemSendLine ("ATDT " & txtPhone.Text)
        strTemp = ModemWaitResponse(60)
        If CancelNow Then Exit Sub
        Connected = False
        Select Case strTemp
            Case "OK":
            Case "CONNECT":
                sbrStatus.Panels("Status").Text = "Status: Connected"
                StartTiming
                Connected = True
                Dialing = False
                Exit Sub
            Case "NO CARRIER":
                sbrStatus.Panels("Status").Text = "Status: No Carrier"
            Case "ERROR":
                sbrStatus.Panels("Status").Text = "Status: Modem Error"
            Case "BUSY":
                sbrStatus.Panels("Status").Text = "Status: Busy"
            Case "NO ANSWER":
                sbrStatus.Panels("Status").Text = "Status: NO Answer"
            Case "NO DIAL TONE":
                sbrStatus.Panels("Status").Text = "Status: No Dial Tone"
            Case "RING"
                sbrStatus.Panels("Status").Text = "Status: Ring"
            Case Else
        End Select
        X = Hangup
        Retries = Retries - 1
        lblRetries = Retries
    Loop
    Dialing = False
End Sub

Private Sub cmdHangup_Click()
    Dim X As Integer
    CancelNow = True
    X = Hangup
    Dialing = False
End Sub

Private Sub Form_Load()
    Timer1.Enabled = False
    CancelNow = False
    Connected = False
    Me.Show
    If (InitializeModem = False) Then
        MsgBox "Could not initialize modem"
    End If
End Sub

Private Sub txtTerm_KeyPress(KeyAscii As Integer)
    If MSComm1.PortOpen Then
        MSComm1.Output = Chr$(KeyAscii)
        If (Connected) Then
            ShowData txtTerm, (Chr$(KeyAscii))
            txtTerm.SelStart = Len(txtTerm)
            KeyAscii = 0
        End If
    End If
     
End Sub



Private Sub Timer1_Timer()
    sbrStatus.Panels("ConnectTime").Text = Format(Now - StartTime, "hh:nn:ss") & " "
End Sub