frmlogon.frm

vb代码集,收集许多VB网络编程代码

    ' Read the message and headers and put it in
    ' the appropriate textboxes.
    With frmRead
        .lblFrom = mapMess.MsgOrigDisplayName
        .lblCC = GetList(mapCcList)
        .lblTo = GetList(mapToList)
        .lblSubject = mapMess.MsgSubject
        .txtRead = mapMess.MsgNoteText
    End With
    grdMess.Columns("Read").Text = "X"
    
    frmRead.Show vbModal
    
    Exit Sub
RowERR:
    Debug.Print Err.Number, Err.Description
    Resume Next


End Sub




Private Sub CheckRS()
    ' Check a flag, gbRSalreadyPopulated before
    ' continuing. Clear the recordset before
    ' populating it again.
    If gbRSalreadyPopulated Then
        ClearRS
        PopulateRS
    Else
        PopulateRS
        gbRSalreadyPopulated = True
    End If
End Sub

Private Sub DoGrid()
    ' Check a flag, gbGridConfigured, before
    ' continuing. If already configured, clear it.
    If gbGridConfigured Then
        gbIgnoreEvent = True
        grdMess.HoldFields ' Retain grid configuration.
        Set grdMess.DataSource = rsUnread
        gbIgnoreEvent = False
    Else
        ConfigureGrid
    End If

End Sub

Private Sub ComposeMessage()
    On Error GoTo ComposeErr
    Dim strMessage As String
    ' Use the Compose method and then invoke the
    ' Send method. When the optional argument
    ' is set to True, the underlying mail system's
    ' form is used. Otherwise, you must create your
    ' own.
    mapMess.Compose
    mapMess.Send True
    
    Exit Sub
ComposeErr:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub CreateRS()
    ' Create ADO recordset and add fields. Each field becomes a
    ' column in the DataGrid control.
    
    Set rsUnread = New ADODB.Recordset
    With rsUnread.Fields
        .Append "ID", adSmallInt
        .Append "Read", adBSTR
        .Append "Date Received", adDate
        .Append "From", adBSTR
        .Append "Subject", adBSTR
    End With
    rsUnread.Open
End Sub


Private Sub FetchUnreadOnly()
    With mapMess
         ' Fetch unread messages only, then display number
         ' of unread messages in Statusbar.
        .FetchUnreadOnly = True
        .Fetch
        sbrMapi.Panels("MsgCnt").Text = .MsgCount & " Messages"
    End With
End Sub

Private Sub ClearRS()
    ' Clear the recordset of all rows.
    If rsUnread.RecordCount = 0 Then Exit Sub
    Dim i As Integer
    gbIgnoreEvent = True
    
    rsUnread.MoveFirst
    For i = 1 To rsUnread.RecordCount
        rsUnread.Delete adAffectCurrent
        DoEvents
    Next i
    gbIgnoreEvent = False

End Sub
Private Sub PopulateRS()
    gbIgnoreEvent = True ' Flag to prevent RowColChanged event from processing.
    Dim i As Integer
    For i = 0 To mapMess.MsgCount - 1
        mapMess.MsgIndex = i
        rsUnread.AddNew
        rsUnread!ID = i
        rsUnread![date received] = mapMess.MsgDateReceived
        rsUnread!From = mapMess.MsgOrigDisplayName
        rsUnread!subject = mapMess.MsgSubject
    Next i
    gbIgnoreEvent = False ' Reset flag.
    
End Sub
Private Sub ConfigureGrid()
    ' Set the width of the grid columns before
    ' setting the DataSource to the recordset.
    
    gbIgnoreEvent = True
    With grdMess
        Set .DataSource = rsUnread ' Fires event.
        .Columns("ID").Width = 0   ' Hide ID column.
        .Columns("Read").Width = 500
        .Columns("Date Received").Width = 900
        .Columns("From").Width = 2000
        .Columns("Subject").Width = 5000
    End With
    Dim fmtdate As StdDataFormat
    
    ' Use the Format object to format the
    ' date column.
    Set fmtdate = New StdDataFormat
    With fmtdate
        .Type = fmtCustom
        .Format = "Short Date"
     End With
    Set grdMess. _
    Columns("Date Received").DataFormat = fmtdate
    
    gbIgnoreEvent = False
    gbGridConfigured = True ' Set flag so we know
    ' we don't have to do this again.
End Sub


Private Function LogOn() As Boolean
    ' Create Recordset Object named rsUnread
    CreateRS

    ' If a session is already started,
    ' exit sub.
    If mapSess.NewSession Then
        MsgBox "Session already established"
        Exit Function
    End If
    
    On Error GoTo errLogInFail
    With mapSess
        ' Set DownLoadMail to False to prevent immediate download.
        .DownLoadMail = False
        .LogonUI = True ' Use the underlying email system's logon UI.
        .SignOn ' Signon method.
        ' If successful, return True
        LogOn = True
        ' Set NewSession to True and set0
        ' variable flag to true
        .NewSession = True
        bNewSession = .NewSession
        mapMess.SessionID = .SessionID ' You must set this before continuing.
        sbrMapi.Panels("SessID") = "ID = " & .SessionID ' Just so you can see the SessionID.
    End With
    ' Enabled and disable buttons.
    ToggleButtonEnabled
    Exit Function
    
errLogInFail:
    Debug.Print Err.Number, Err.Description
    If Err.Number = 32003 Then
        MsgBox "Canceled Login"
        LogOn = False
    End If
    Exit Function
End Function
Private Sub LogOff()
    ' Logoff the MapSessions control.
    With mapSess
        .SignOff ' Close the session.
        .NewSession = False ' Flag for new session.
        bNewSession = .NewSession ' Reset flag.
    End With
    ' Disable and enable buttons.
    ToggleButtonEnabled
    
    rsUnread.Close ' Close ADO recordset and set variable to Nothing.
    Set rsUnread = Nothing
    gbRSalreadyPopulated = False
    Unload frmRead ' Unload the form.
    grdMess.ClearFields ' Clear the grid.
End Sub

Private Sub ToggleButtonEnabled()
    ' Toggle Enabled property of various buttons.
    With tbrMail
        .Buttons("LogOn").Enabled = Abs(.Buttons("LogOn").Enabled) - 1
        .Buttons("logOff").Enabled = Abs(.Buttons("logOff").Enabled) - 1
        .Buttons("fetch").Enabled = Abs(.Buttons("fetch").Enabled) - 1
        .Buttons("compose").Enabled = Abs(.Buttons("compose").Enabled) - 1
        .Buttons("address").Enabled = Abs(.Buttons("address").Enabled) - 1
        .Buttons("address").ButtonMenus(1).Enabled = Abs(.Buttons("address").ButtonMenus(1).Enabled) - 1
        .Buttons("address").ButtonMenus(2).Enabled = Abs(.Buttons("address").ButtonMenus(2).Enabled) - 1
        
    End With
    
    ' Toggle menu enabled.
    mnuLogOn.Enabled = Abs(mnuLogOn.Enabled) - 1
    mnuLogOff.Enabled = Abs(mnuLogOff.Enabled) - 1
    mnuTools.Enabled = Abs(mnuTools.Enabled) - 1
    mnuCheck.Enabled = Abs(mnuCheck.Enabled) - 1
    mnuAddress.Enabled = Abs(mnuAddress.Enabled) - 1

End Sub

Private Function GetList(ListType As Integer) As String
    ' The function just gets all the recipients
    ' of a message and contatenates them.
    Dim i As Integer
    Dim strList As String
    For i = 0 To mapMess.RecipCount - 1
        mapMess.RecipIndex = i
        If mapMess.RecipType = ListType Then
            strList = strList & mapMess.RecipDisplayName & "; "
        End If
    Next i
    If strList = "" Then
        GetList = ""
        Exit Function
    End If
    ' Strip semicolon from last recipient name.
    GetList = Left(strList, Len(strList) - 2)

End Function


Private Sub mnuAddress_Click()
    ' Display the Addressbook.
    On Error GoTo AddressErr
    mapMess.Show True
    Exit Sub
AddressErr:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub mnuCheck_Click()
    FetchUnreadOnly ' Fetch unread messages.
    CheckRS ' Check Recordset and fill.
    DoGrid ' Set Grid's DataSource to recordset.
    
End Sub

Private Sub mnuExit_Click()
    ' Sign off if not done yet, then unload form.
    If mapSess.SessionID <> 0 Then mapSess.SignOff
    Unload Me
End Sub

Private Sub mnuLogOff_Click()
    LogOff
End Sub

Private Sub mnuLogOn_Click()
    If LogOn = True Then
        FetchUnreadOnly
        CheckRS
        DoGrid
    Else
        Exit Sub
    End If
End Sub

Private Sub tbrMail_ButtonMenuClick(ByVal ButtonMenu As MSComCtlLib.ButtonMenu)
    On Error GoTo btnClickErr
    Select Case ButtonMenu.Key
    Case "global"
        mapMess.Show False
    Case "recepient"
        mapMess.Show True
    End Select
    Exit Sub
btnClickErr:
    If Err.Number = mapUserAbort Then
        Resume Next
    Else
        MsgBox Err.Number & ": " & Err.Description
    End If
    
End Sub