module1.bas

很好的

Attribute VB_Name = "Module1"
Public Const conMailLongDate = 0
Public Const conMailListView = 1
'标识取消发送的变量
Public SendWithApi
Public Const conOptionGeneral = 1
Public Const conOptionMessage = 2
Public Const conUnreadMessage = "*"
Public Const vbRecipTypeTo = 1
Public Const vbRecipTypeCc = 2
'定义当 MAPIMessages 控件被激活时，Action属性使用的常数
'该属性决定将执行什么操作
Public Const vbMessageFetch = 1
Public Const vbMessageSenddlg = 2
Public Const vbMessageSend = 3
Public Const vbMessageSaveMsg = 4
Public Const vbMessageCopy = 5
Public Const vbMessageCompose = 6
Public Const vbMessageReply = 7
Public Const vbMessageReplyAll = 8
Public Const vbMessageForward = 9
Public Const vbMessageDelete = 10
Public Const vbMessageShowADBook = 11
Public Const vbMessageShowDetails = 12
Public Const vbMessageResolveName = 13
Public Const vbRecipientDelete = 14
Public Const vbAttachmentDelete = 15
Public Const vbAttachTypeData = 0
Public Const vbAttachTypeEOLE = 1
Public Const vbAttachTypeSOLE = 2
'定义存储邮件信息的结构
Type ListDisplay
     Name As String * 20
     Subject As String * 40
     Date As String * 20
End Type
Public currentRCIndex As Integer
Public UnRead As Integer
Public SendWithMapi As Integer
Public ReturnRequest As Integer
Public OptionType As Integer
    
'声明读取注册表内容的函数
#If Win32 Then
Public Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
#Else
Public Declare Function GetProfileString% Lib "kernel" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long)
#End If

Public Sub Attachments(msg As Form)
'将有附件的信息装载到窗体msg的列表框alist中
msg.alist.Clear
msg.numAtt = "附加文件数量：" & VBMail.MAPIMess.AttachmentCount
If VBMail.MAPIMess.AttachmentCount Then
    For i% = 0 To VBMail.MAPIMess.AttachmentCount - 1
    VBMail.MAPIMess.AttachmentIndex = i%
    a$ = VBMail.MAPIMess.AttachmentName
    Select Case VBMail.MAPIMess.AttachmentType
        Case vbAttachTypeData
            a$ = a$ + "(Data File)"
        Case vbAttachTypeEOLE
            a$ = a$ + "(Embedded OLE Object)"
        Case vbAttachTypeSOLE
            a$ = a$ + "(Static OLEObject)"
        Case Else
            a$ = a$ + "(Unknown attachment type)"
    End Select
    msg.alist.AddItem a$
    Next i%
End If
msg.Refresh
End Sub

Public Sub CopyNamestoMsgBuffer(msg As Form, fResolveNames As Integer)
'删除原来的收信人地址
Call KillRecips(VBMail.MAPIMess)
'窗体msg中填写的收信人和抄送人地址添加到发送邮件的地址
Call SetRCList(msg.txtTo, VBMail.MAPIMess, vbRecipTypeTo, fResolveNames)
Call SetRCList(msg.txtCc, VBMail.MAPIMess, vbRecipTypeTo, fResolveNames)
End Sub

Public Function DateFromMapiDate$(ByVal S$, wFormat%)
'该函数的功能根据给定的日期，返回一定格式的日期的表示形式
Y$ = Left$(S$, 4)
M$ = Mid$(S$, 6, 2)
D$ = Mid$(S$, 9, 2)
T$ = Mid$(S$, 12)
Ds# = DateValue(M$ + "/" + D$ + "/" + Y$) + TimeValue(T$)
Select Case wFormat
    Case conMailLongDate
        f$ = "dddd,mmmm,d,yyyy,h:mmAM/PM"
    Case conMailListView
        f$ = "mm/dd/yy hh:mm"
End Select
DateFromMapiDate = Format$(Ds#, f$)
End Function

Public Sub DeleteMessage()
'该子程序的删除当前选中的邮件
If TypeOf Screen.ActiveForm Is MsgView Then
    MailLst.Mlist.ListIndex = Val(Screen.ActiveForm.Tag)
    ViewingMsg = ture
End If
If MailLst.Mlist.ListIndex <> -1 Then
    '如果消息索引不等与-1（不是在书写新信件），则删除当前消息
    VBMail.MAPIMess.MsgIndex = MailLst.Mlist.ListIndex
    VBMail.MAPIMess.Action = vbMessageDelete
    '从列表框中删除相应的消息
    x% = MailLst.Mlist.ListIndex
    MailLst.Mlist.RemoveItem x%
    If x% < MailLst.Mlist.ListCount - 1 Then
        MailLst.Mlist.ListIndex = x%
    Else
        MailLst.Mlist.ListIndex = MailLst.Mlist.ListCount - 1
    End If
    VBMail.Statusbar1.Panels(1) = "收信箱里共有" + Format$(VBMail.MAPIMess.MsgCount) + "邮件，其中有" + Format$(UnRead) + "未读"
    If ViewingMsg Then
        '删除当前活动窗体的消息后，将其标志设为-1
        Screen.ActiveForm.Tag = Str$(-1)
    End If
    For i = 0 To Forms.Count - 1
        If TypeOf Forms(i) Is MsgView Then
            If Val(Forms(i).ta) > x% Then
                '将阅读邮件的窗体的tag属性设为邮件的索引
                Forms(i).Tag = Val(Forms(i).Tag) - 1
            End If
        End If
    Next i
    If vewingmsg Then
        '在删除当前邮件后，下一封邮件的位置设置为当前位置，这时需要
        '判断该邮件是否已经在子窗体MsgView中显示，如是，将其设为活动
        '窗体，否则，用MsgView显示该邮件
        windowNum% = FindMsgWindow(MailLst.Mlist.ListIndex)
        If windowNum% > 0 Then
            If Forms(windowNum%).Caption <> Screen.ActiveForm.Caption Then
                Unload Screen.ActiveForm
                Forms(FindMsgWindow((MailLst.Mlist.ListIndex))).Show
            Else
                Forms(windowNum%).Show
            End If
        Else
            Call LoadMessage(MailLst.Mlist.ListIndex, Screen.ActiveForm)
        End If
    Else
        windowNum% = FindMsgWindow(x%)
        If windowNum% > 0 Then
           Unload Forms(x%)
        End If
    End If
End If
End Sub

Public Sub DisplayAttachedFile(ByVal FileName As String)
'该子程序用于根据文件的类型查看附件文件
On Error Resume Next
ext$ = FileName
junk$ = Token$(ext$, ".")
Buffer$ = String$(256, "")
errCode% = GetProfileString("Extensions", ext$, "NOTFOUND", Buffer$, Len(Left(Buffer$, Chr(0)) - 1))
If errCode% Then
    Buffer$ = Mid$(Buffer$, 1, InStr(Buffer$, Chr(0)) - 1)
    If Buffer$ <> "NOTFOUND" Then
        EXEName$ = Token$(Buffer$, "")
        errCode% = Shell(EXEName$ + "" + FileName, 1)
        If Err Then
            MsgBox "Error occurred during the shell:" + Error$
         End If
    Else
        MsgBox "Appliction that uses:<" + ext$ + ">not found in WIN.INI"
    End If
End If
End Sub

Public Function FindMsgWindow(Index As Integer) As Integer
'判断当前所有子窗体中是否包含有相对邮件索引的邮件
'如果没有则返回值为-1
For i = 0 To Forms.Count - 1
    If TypeOf Forms(i) Is MsgView Then
        If Val(Forms(i).Tag) = Index Then
            FindMsgWindow = i
            Exit Function
        End If
    End If
Next i
FindMsgWindow = -1
End Function

Public Function GetHeader(msg As Control)
'从MAPIMessages控件取得邮件的头信息
Dim CR As String
CR = Chr$(13) + Chr$(10)
Header$ = String$(25, "-")
Header$ = Header$ + "From:" + msg.MsgOrigDisplayName + CR
Header$ = Header$ + "To:" + GetRCList(msg, vbRecipTypeTo) + CR
Header$ = Header$ + "Cc:" + GetRCList(msg, vbRecipTypeCc) + CR
Header$ = Header$ + "Subject:" + msg.MsgSubject + CR
Header$ = Header$ + "Date:" + _
DateFromMapiDate$(msg.MsgDateReceived, conMailLongDate) + CR + CR
GetHeader = Header$
End Function

Public Sub GetMessageCount()
'获得邮箱中所有消息（邮件）的数量
Screen.MousePointer = 11
VBMail.MAPIMess.FetchUnreadOnly = 0
VBMail.MAPIMess.Action = vbMessageFetch
VBMail.Statusbar1.Panels(1) = "收信箱里共有" + Format$(VBMail.MAPIMess.MsgCount) + "邮件"
Screen.MousePointer = 0
End Sub

Public Function GetRCList(msg As Control, RCType As Integer) As String
'从MAPIMessages控件中获得所有收信人的姓名，
'姓名之间用分号隔开，返回值为所有收信人姓名
For i = 0 To msg.RecipCount - 1
    msg.RecipIndex = i
    If RCType = msg.RecipType Then
        a$ = a$ + ";" + msg.RecipDisplayName
    End If
Next i
If a$ <> "" Then
    a$ = Mid$(a$, 2)
End If
GetRCList = a$
End Function

Public Sub KillRecips(Msgcontrol As Control)
'从MAPIMessages控件中删除所有收信人地址
While Msgcontrol.RecipCount
    Msgcontrol.Action = vbRecipientDelete
Wend
End Sub

Public Sub LoadList(mailctl As Control)
'将邮件的信息装载到邮件列表窗体中的列表框
MailLst.Mlist.Clear
UnRead = 0
startindex = 0
For i = 0 To mailctl.MsgCount - 1
    mailctl.MsgIndex = i
    If Not mailctl.MsgRead Then