module1.bas

emai的收发实现,有界面,有源码,非常齐全 是vb学习的绝佳教材

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 = "附加文件数量：" & Main.MAPIMess.AttachmentCount
    If Main.MAPIMess.AttachmentCount Then
        For i% = 0 To Main.MAPIMess.AttachmentCount - 1
        Main.MAPIMess.AttachmentIndex = i%
        a$ = Main.MAPIMess.AttachmentName
        Select Case Main.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(Main.MAPIMess)
    '窗体msg中填写的收信人和抄送人地址添加到发送邮件的地址
    Call SetRCList(msg.txtTo, Main.MAPIMess, vbRecipTypeTo, fResolveNames)
    Call SetRCList(msg.txtCc, Main.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 Form2 Then
        Form1.Mlist.ListIndex = Val(Screen.ActiveForm.Tag)
        ViewingMsg = ture
    End If
    If Form1.Mlist.ListIndex <> -1 Then
        '如果消息索引不等与-1（不是在书写新信件），则删除当前消息
        Main.MAPIMess.MsgIndex = Form1.Mlist.ListIndex
        Main.MAPIMess.Action = vbMessageDelete
        '从列表框中删除相应的消息
        x% = Form1.Mlist.ListIndex
        Form1.Mlist.RemoveItem x%
        If x% < Form1.Mlist.ListCount - 1 Then
            Form1.Mlist.ListIndex = x%
        Else
            Form1.Mlist.ListIndex = Form1.Mlist.ListCount - 1
        End If
        Main.Statusbar1.Panels(1) = "收信箱里共有" + Format$(Main.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 Form2 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
            '在删除当前邮件后，下一封邮件的位置设置为当前位置，这时需要
            '判断该邮件是否已经在子窗体Form2中显示，如是，将其设为活动
            '窗体，否则，用Form2显示该邮件
            windowNum% = FindMsgWindow(Form1.Mlist.ListIndex)
            If windowNum% > 0 Then
                If Forms(windowNum%).Caption <> Screen.ActiveForm.Caption Then
                    Unload Screen.ActiveForm
                    Forms(FindMsgWindow((Form1.Mlist.ListIndex))).Show
                Else
                    Forms(windowNum%).Show
                End If
            Else
                Call LoadMessage(Form1.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 "在shell中发生错误！！！" + Error$
             End If
        Else
            MsgBox "在WIN.INI没发现使用" + ext$ + "的程序！！！"
        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 Form2 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
    Main.MAPIMess.FetchUnreadOnly = 0
    Main.MAPIMess.Action = vbMessageFetch
    Main.Statusbar1.Panels(1) = "收信箱里共有" + Format$(Main.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