frmlogon.frm

< VB高级网络编程技术>>随书源代码第2章,里面有很多有用的例程,希望对大家的开发工作有帮助!

Case "fetch"
    MyFetchMail
    '检查ADO Recordset是否已经被组织。然后组织窗格
    CheckRS
    DoGrid
Case "compose" '创建新的信息
    ComposeMessage
Case "address"
    Debug.Print "something else"
Case Else
    Debug.Print Button.Key
End Select
Exit Sub
ButtonErr:
Debug.Print Err.Number, Err.Description
Resume Next
End Sub

Private Sub grdMess_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
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("Read").Text = "X"
frmRead.Show
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 方法。当可选的参数
'被设置为 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 "Read", adBSTR
    .Append "Date Received", adDate
    .Append "From", adBSTR
    .Append "Subject", adBSTR
End With
rsUnread.Open
End Sub


Private Sub MyFetchMail()
With mapMess
     '只取未读信息，然后在状态栏中显示未读信息数。
    .FetchUnreadOnly = False
    .Fetch
    sbrMapi.Panels("MsgCnt").Text = .MsgCount & " Messages"
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
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![date received] = mapMess.MsgDateReceived
    rsUnread!From = mapMess.MsgOrigDisplayName
    rsUnread!subject = 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("Read").Width = 500
    .Columns("Date Received").Width = 900
    .Columns("From").Width = 2000
    .Columns("Subject").Width = 5100
End With
Dim fmtdate As StdDataFormat

'使用 Format 对象来格式化日期列。
Set fmtdate = New StdDataFormat
With fmtdate
    .Type = fmtCustom
    .Format = "Short Date"
 End With
Set grdMess. _
Columns("Date Received").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
    '.UserName = "WXP"
    '设置 DownLoadMail 为 False 来防止直接下载。
    .DownLoadMail = False
    .LogonUI = True '使用下列的电子邮件系统的登录 UI。
    .SignOn 'Signon method.
    ' 如果成功，则返回 True 。
    LogOn = True
    ' 设置 NewSession 为真并且 set0
    ' 变量的标志也为真。
    .NewSession = True
    bNewSession = .NewSession
    mapMess.SessionID = .SessionID '您必须在继续前设置它
    sbrMapi.Panels("SessID") = "ID = " & .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 = .NewSession ' 重新设置标志。
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
'切换DataGrid的可见属性
grdMess.Visible = Not (mnuLogOn.Enabled)
    
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()
MyFetchMail ' 取未读信息。
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
    MyFetchMail
    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