Outlook add-ins webcasts讲座代码之一（创建菜单）

link

Imports Microsoft.Office.Core

Partial Public Class ThisApplicationClass ThisApplication

    Private Const _MENU_BEFORE As String = "帮助"

    'outlook的菜单栏
    Dim _menuBar As Office.CommandBar = Nothing

    '顶级菜单按钮
    Dim _topMenu As Office.CommandBarPopup

    '导入学生信息的菜单按钮
    Dim _menuInputStudents As Office.CommandBarButton

    '保存菜单的位置
    Dim _menuIndex As Integer

    '处理"导入学员信息"菜单的点击事件
    Private Sub _menuInputStudents_Click()Sub _menuInputStudents_Click(ByVal Ctrl As Microsoft.Office.Core.CommandBarButton, ByRef CancelDefault As Boolean)
        '创建学员文件夹
        Dim contactFolder As Outlook.MAPIFolder = CreateContactsFolder()
        '从数据库中引入所有的学员
        ImportsAllStudents(contactFolder)
        '创建快捷方式
        CreateStudentsShortcut()
    End Sub

    Public Sub CreateMenus()Sub CreateMenus()
        '获得Outlook的菜单栏
        _menuBar = Me.ActiveExplorer().CommandBars.ActiveMenuBar

        If (Not (_menuBar Is Nothing)) Then
            _menuIndex = _menuBar.Controls.Count

            '添加顶级菜单
            _topMenu = _menuBar.Controls.Add(Office.MsoControlType.msoControlPopup, _
                                    Type.Missing, _
                                    Type.Missing, _
                                    _menuIndex, _
                                    True)
            _topMenu.Caption = "学员信息管理"
            _topMenu.Visible = True

            '添加导入学员信息的菜单
            _menuInputStudents = _topMenu.Controls.Add(Office.MsoControlType.msoControlButton, _
                                    Type.Missing, _
                                    Type.Missing, _
                                    Type.Missing, _
                                    True)
            _menuInputStudents.Caption = "导入学员信息"
            _menuInputStudents.Visible = True
            '为菜单增加点击事件处理函数
            AddHandler _menuInputStudents.Click, AddressOf _menuInputStudents_Click
        End If
    End Sub

    Private Sub CreateWelcomeMail()Sub CreateWelcomeMail(ByVal contact As Outlook.ContactItem)
        '创建邮件
        Dim mail As Outlook.MailItem = Me.CreateItem(Outlook.OlItemType.olMailItem)

        '创建邮件内容
        mail.To = contact.Email1Address
        mail.Subject = "欢迎来到新天地电脑培训"

        mail.HTMLBody = "<H3>亲爱的" + contact.LastName + "， 您好</H3><br><br>"
        mail.HTMLBody += "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 欢迎您来到新天地电脑培训<br><br>"
        mail.HTMLBody += Now.ToLongDateString

        '关闭邮件并保存
        mail.Close(Outlook.OlInspectorClose.olSave)
    End Sub
    '从数据库中导入所有的学员信息
    Private Sub ImportsAllStudents()Sub ImportsAllStudents(ByVal contactFolder As Outlook.MAPIFolder)
        Dim _row As DataRow
        Dim customProperty As Outlook.UserProperty

        '定义数据集
        Dim ds As DataSet = New DataSet()
        '连接数据库
        Dim adapter As OleDb.OleDbDataAdapter = New OleDb.OleDbDataAdapter("select * from T_Student", _
                "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=""C:\Documents and Settings\陈锐\My Documents\VBA webcasts\outlook\students.mdb""")
        '填充数据集
        adapter.Fill(ds, "Students")

        Dim count As Integer = 0

        '访问当前的所有学生
        For Each _row In ds.Tables("Students").Rows

            '判断联系人中是否已经存在
            If (Not IsContactExist(_row("StudentName"), _row("StudentCode"))) Then
                Dim _contact As Outlook.ContactItem

                '创建一个新的联系人
                _contact = Me.CreateItem(Outlook.OlItemType.olContactItem)

                '为联系人增加一个&#8220;StudentsCode&#8221;的自定义字段
                customProperty = _contact.UserProperties.Add("StudentsCode", _
                                Outlook.OlUserPropertyType.olText)

                '设置联系人属性
                customProperty.Value = _row("StudentCode").ToString()

                _contact.MailingAddress = _row("Address").ToString()
                _contact.Email1Address = _row("EMail").ToString()
                _contact.LastName = _row("StudentName").ToString()
                _contact.MobileTelephoneNumber = _row("CellPhone").ToString()
                _contact.HomeTelephoneNumber = _row("HomePhone").ToString()
                _contact.BusinessTelephoneNumber = _row("OfficePhone").ToString()

                '设置联系人的分类
                _contact.Categories = "Students"

                '保存联系人
                _contact.Save()

                '将联系人移动到新创建的文件夹中
                _contact.Move(contactFolder)

                '对每个新建的联系人发送一个欢迎邮件
                CreateWelcomeMail(_contact)
                count += 1
            End If
        Next
        MsgBox("学员信息导入完成！共导入" + count.ToString() + "条信息！")
    End Sub

    '判断联系人是否存在
    Private Function IsContactExist()Function IsContactExist(ByVal StudentName As String, ByVal StudentCode As String) As Boolean
        Dim inbox As Outlook.MAPIFolder = Me.ActiveExplorer().Session. _
                    GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)

        ' 获得收件箱下面所有的子文件夹
        Dim inboxFolders As Outlook.Folders = inbox.Folders

        Dim studentFolder As Outlook.MAPIFolder = Nothing

        Dim folder As Outlook.MAPIFolder = Nothing

        '遍历子文件夹
        For Each folder In inboxFolders
            If (folder.Name.Equals("Student")) Then
                studentFolder = folder
                Exit For
            End If
        Next

        'Dim item As Object
        Dim contact As Outlook.ContactItem = Nothing
        If (Not (studentFolder Is Nothing)) Then
            '首先根据姓名找到联系人
            contact = studentFolder.Items.Find("[LastName] = '" + StudentName + "'")

            While (Not (contact Is Nothing))
                Try
                    '判断联系人的学号
                    If (contact.UserProperties("StudentsCode").Value = StudentCode) Then
                        Return True
                    End If
                Catch ex As Exception

                End Try
                contact = studentFolder.Items.FindNext
            End While

            Return False
        Else
            Return False
        End If
    End Function

    '创建新的联系人文件夹
    Private Function CreateContactsFolder()Function CreateContactsFolder() As Outlook.MAPIFolder
        '获得当前的收件箱文件夹
        Dim inbox As Outlook.MAPIFolder = Me.ActiveExplorer().Session. _
            GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)

        ' 获得收件箱下面所有的子文件夹
        Dim inboxFolders As Outlook.Folders = inbox.Folders

        Dim studentFolder As Outlook.MAPIFolder = Nothing


        Dim folder As Outlook.MAPIFolder = Nothing
        '判断Student文件夹是否存在
        For Each folder In inboxFolders
            If (folder.Name.Equals("Student")) Then
                studentFolder = folder
                Exit For
            End If
        Next

        '如果不存在则创建
        If studentFolder Is Nothing Then
            studentFolder = inboxFolders.Add("Student", _
                    Outlook.OlDefaultFolders.olFolderContacts)
        End If

        '返回Student文件夹
        Return studentFolder
    End Function


    Private Sub CreateStudentsShortcut()Sub CreateStudentsShortcut()
        ' 获得快捷方式面板
        Dim barStudent As Outlook.OutlookBarPane = Me.ActiveExplorer().Panes(Outlook.OlPane.olOutlookBar)

        ' 显示快捷方式面板
        barStudent.Visible = True

        ' 为显示学员快捷方式创建的Group
        Dim groupStudent As Outlook.OutlookBarGroup = barStudent.Contents.Groups.Add("学员信息管理", Type.Missing)

        ' 获得收件箱
        Dim inbox As Outlook.MAPIFolder = Me.ActiveExplorer().Session.GetDefaultFolder(Outlook.OlDefaultFolders.olFolderInbox)

        ' 获得收件箱下面的所有子文件夹
        Dim inboxFolders As Outlook.Folders = inbox.Folders

        ' 获得学员文件夹
        Dim studentsFolder As Outlook.MAPIFolder = inbox.Folders("Student")

        ' 在快捷方式面板上创建一个新的快捷方式
        Dim shortcut As Outlook.OutlookBarShortcut = Nothing
        shortcut = groupStudent.Shortcuts.Add(studentsFolder, "察看所有学员", Type.Missing)
    End Sub
End Class