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