11-3.frm

来自「vb6.0编程实例详解,很详细的介绍,对学习VB有帮助」· FRM 代码 · 共 602 行 · 第 1/2 页

    If mapSess.SessionID = 0 Or mapMess.MsgCount = 0 Then Exit Sub '未连接邮件服务器
    grdMess.Row = grdMess.RowContaining(Y)
    If gbIgnoreEvent Then Exit Sub '数据更新时，禁止事件处理
  
    On Error GoTo RowERR
    mapMess.MsgIndex = grdMess.Columns(0).Value ' 设置 MsgIndex.
    
    Load frmRead ' 加载此窗体。
    ' 对信息及标题并且将它们放在适当的文本框中。
    With frmRead
        .lblFrom = mapMess.MsgOrigDisplayName
        .lblCC = GetList(mapCcList)
        .lblTo = GetList(mapToList)
        .lblSubject = mapMess.MsgSubject
        .txtRead = mapMess.MsgNoteText
    End With
    grdMess.Columns("已读").Text = "   X"
    
    frmRead.Show vbModal
    
    Exit Sub
RowERR:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub CheckRS()
    ' 在继续运行前检查标志 gbRSalreadyPopulated
    ' 然后清除记录集。
    If gbRSalreadyPopulated Then
        ClearRS
        PopulateRS
    Else
        PopulateRS
        gbRSalreadyPopulated = True
    End If
End Sub

Private Sub DoGrid()
    ' 在继续运行前检查标志 gbGridConfigured,
    ' 如果已经被配置，则清除它。
    If gbGridConfigured Then
        gbIgnoreEvent = True
        grdMess.HoldFields ' 保持网格设置.
        Set grdMess.DataSource = rsUnread
        gbIgnoreEvent = False
    Else
        ConfigureGrid
    End If

End Sub

Private Sub ComposeMessage()
    On Error GoTo ComposeErr
    Dim strMessage As String
    ' 使用 Compose 方法并激活 Send 方法。
    ' 当 Send 方法的可选参数为 True 时, 显示缺省邮件发送窗体，
    ' 否则不显示缺省窗体。
    mapMess.Compose
    mapMess.Send True
    
    Exit Sub
ComposeErr:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub

Private Sub CreateRS()
    ' 创建 ADO 记录集并且添加字段。每个字段在
    ' DataGrid 控件中形成一列。
    
    Set rsUnread = New ADODB.Recordset
    With rsUnread.Fields
        .Append "ID", adSmallInt
        .Append "已读", adBSTR
        .Append "接收时间", adDate
        .Append "发件人", adBSTR
        .Append "主题", adBSTR
    End With
    rsUnread.Open
End Sub


Private Sub FetchUnreadOnly()
    With mapMess
         ' 只取未读信息，然后在状态栏中显示未读信息数。
        .FetchUnreadOnly = True
        .Fetch
        sbrMapi.Panels("MsgCnt").Text = .MsgCount & " 条消息"
    End With
End Sub

Private Sub ClearRS()
    ' 清除所有行的记录集。
    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 '执行VB事件
    Next i
    gbIgnoreEvent = False
End Sub
Private Sub PopulateRS()
    gbIgnoreEvent = True ' 防止 RowColChanged 事件发生。
    Dim i As Integer
    For i = 0 To mapMess.MsgCount - 1
        mapMess.MsgIndex = i
        rsUnread.AddNew
        rsUnread!ID = i
        rsUnread!接收时间 = mapMess.MsgDateReceived
        rsUnread!发件人 = mapMess.MsgOrigDisplayName
        rsUnread!主题 = mapMess.MsgSubject
    Next i
    gbIgnoreEvent = False ' 重新设置标志。
    
End Sub
Private Sub ConfigureGrid()
    ' 在设置 DataSource 到记录集前，设置窗格列的宽度。
    
    gbIgnoreEvent = True
    With grdMess
        Set .DataSource = rsUnread ' 激活事件
        .Columns("ID").Width = 0   ' 隐藏 ID 列。
        .Columns("已读").Width = 500
        .Columns("接收时间").Width = 900
        .Columns("发件人").Width = 2000
        .Columns("主题").Width = 5000
    End With
    
    Dim fmtdate As StdDataFormat
    ' 使用 Format 对象来格式化日期列。
    Set fmtdate = New StdDataFormat
    With fmtdate
        .Type = fmtCustom
        .Format = "Short Date"
     End With
    Set grdMess.Columns("接收时间").DataFormat = fmtdate
    
    gbIgnoreEvent = False
    gbGridConfigured = True ' 设置配置好标志。
End Sub


Private Function LogOn() As Boolean
    ' 创建名为 rsUnread 的 Recordset 对象
    CreateRS

    ' 如果会话已经启动,退出此函数。
    If mapSess.NewSession Then
        MsgBox "会话已经被建立"
        Exit Function
    End If
    
    On Error GoTo errLogInFail
    With mapSess
        ' 设置 DownLoadMail 为 False 来防止直接下载。
        .DownLoadMail = False
        .LogonUI = True ' 使用下列的电子邮件系统的登录 UI。
        .SignOn ' Signon method.
        ' 如果成功，则返回 True 。
        LogOn = True
        ' 设置 NewSession 为真并且 set0
        ' 变量的标志也为真。Set NewSession to True and set0
        ' variable flag to true
        .NewSession = True
        bNewSession = True
        mapMess.SessionID = .SessionID ' 必须在继续前设置
        sbrMapi.Panels("SessID") = "ID = " & .SessionID ' 显示 SessionID 。
    End With
    ' 使按钮可用或禁用。
    ToggleButtonEnabled
    Exit Function
    
errLogInFail:
    Debug.Print Err.Number, Err.Description
    If Err.Number = 32003 Then
        MsgBox "取消登录"
        LogOn = False
    End If
    Exit Function
End Function

Private Sub LogOff()
    ' 注销 MapSessions 控件。
    With mapSess
        .SignOff ' 关闭会话。
        .NewSession = False ' 为新的会话设置标志。
        bNewSession = False ' 重新设置标志。
    End With
    ' 禁用或可用按钮。
    ToggleButtonEnabled
    
    rsUnread.Close ' 关闭 ADO 记录集并且设置变量为没有。
    Set rsUnread = Nothing
    gbRSalreadyPopulated = False
    Unload frmRead ' 卸载此窗体。
    grdMess.ClearFields ' 清除窗格。
End Sub

Private Sub ToggleButtonEnabled()
    ' 切换各个按钮的 Enabled 属性。
    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
    
    ' 切换菜单的可用属性。
    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
    ' 这个函数获得信息的所有接收者
    ' 并且分别对他们进行处理。
    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
    ' 从最后接收者的名称中分离出分号。
    GetList = Left(strList, Len(strList) - 2)

End Function


Private Sub mnuAddress_Click()
    ' 显示地址簿。
    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 ' 取未读信息。
    CheckRS ' 检查记录集并且填充。
    DoGrid ' 设置窗格 DataSource 为记录集。
    
End Sub

Private Sub mnuExit_Click()
    ' 如果没有完成则取消，并且卸载此窗题。
    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