Outlook add-ins webcasts讲座代码之一（创建菜单）
Imports Microsoft.Office.CorePartial 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 += " 欢迎您来到新天地电脑培训<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)
'为联系人增加一个“StudentsCode”的自定义字段
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(" = '" + 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
页:
[1]