问题的产生
Interface Technologies (ITI)的CodeVizor工作组正在努力使他们的新工具引起程序员的注意。在先前的数个月里，成千上万的程序员注册成为ITI's DevCentral的一员，以更方便的试用它们的产品。作为注册的一部份，注册者被询问到他们是否希望得到产品的更新及新产品发布的消息。几乎所有的注册者都希望如此。
因此，工作团队决定向所有六千名注册用户发送一封个人电子邮件信息（当然得除开那些没有留联系EMail的用户）。但是这就出现了个问题：如果是发群体信件，则就违背了发个人邮件的初衷。我们希望的是发往注册用户的邮件是个人化的。因此，我们就得找出一种解决办法，使得发向6000名注册用户的群体邮件是完全个人的，保密的。
目的
我的工作则是写出一个程序，使得它能够进入到DevCentral的注册用户的SQL Server数据库里，然后为每个用户生成一封电子邮件（通过Exchange/Outlook）。
该程序会将待发的EMail保存至outlook，因此就可以组织邮件发送的过程。最好是小批量发送电子邮件，一次发送500封比较合适。这样就可以令到使用者将错误率降到最低，同样也可以降低服务器的负担，加快网络连接速度。同样我们需在邮件上加上回复地址，这样邮件则可以从DevCentral的邮箱里发出，而不是个人的邮箱。
以下将是创建该程序的主要步骤
使用工具及使用目的
通过使用Visual Basic 5.0写出该EmailMaker。该应用程序通过ODBC来进入数据库，并使用VB automation调用Microsoft Outlook以生成电子邮件文本。
最开始的目的本来在于设计出一个简单的基于对话项的程序，使之通过点击按钮就可以完成所有的步骤。但是，这也涉及到了更为多的内容：不但会使得该程序在使用上更为灵活，在功能上也更为强大，也会使我更多的了解VB，比如：combobox控件，属性栏，自定义图标，progress栏，多样化窗口，甚至于非常简单的文件保存及文件格式。因此我努力的将这些分散的VB程序应用知识积累起来，使之能成为一个"真正的程序"
EmailMaker使得用户可以通过数据库向地址列表发送个人化邮件。通过Message Window用户可以书写，编辑并保存邮件内容（同样也可以从其它文本编辑器或文档内复制-粘贴内容）
完成内容书写及保存后，用户则可以开始单个生成标有地址的邮件。当群体邮件位于指定文件夹里时，Send Email 功能则会要求用户分发全体或一部份邮件。
问题及解决方案
开发此程序最大的难点在于Properties form.。
开发此程序的目标之一在于让所有程序的选项来自combobox中，这样可以更便于安装及使用。我做的非常成功除了一个property（Address Sent From，以下我将会提及）。但是，最重要的一个属性包含了数据库及注册的调用功能，因为程序本身需要鉴别用户的数据库及邮件配置，常通过API来鉴别安装了何种ODBC数据库。
以下是源代码
下列数据对于API登录非常有用：
Public Const HKEY_CURRENT_USER = &H80000001
Public Const ERROR_SUCCESS = 0&
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_READ = &H20000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_READ = ((STANDARD_RIGHTS_READ
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And _
(Not SYNCHRONIZE))
Public Const REG_DWORD = 4
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" _
(ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
'-- The subroutine FillODBCCombo is called when the Properties form is loaded.
'-- First the root ODBC key is opened. By iterating through its sub-keys,
'-- all of the installed DNS's are found and inserted into the DNS ComboBox.
Public Sub FillODBCCombo()
Dim hKey As Long
Dim dwIndex As Long
Dim lpData As Long
Dim lpcbData As Long
Dim lngResult As Long
Dim strResult As String
Dim lpValueName As String
Dim lpcbValueName As Long
'-- 每个ODBC数据源都有一个关键字位于
'-- HKEY_CURRENT_USER\Software\ODBC\ODBC.INI\ODBC Data Sources.上
'-- 通过查找每个关键字，能够收集到安装在ODBC上的所有数据源
lngResult = RegOpenKeyEx(HKEY_CURRENT_USER, _
"Software\ODBC\ODBC.INI\ODBC Data Sources", _
0&, _
KEY_READ, _
hKey)
If lngResult <> ERROR_SUCCESS Then
MsgBox "Error opening ODBC registry key."
Exit Sub
End If
dwIndex = 0
'-- Add each DNS to the combo
Do
lpcbValueName = 1000
lpcbData = 1000
lpValueName = String(lpcbValueName, 0)
'-- The RegEnumValue function allows you to
'-- move through the subkeys one at a time
lngResult = RegEnumValue(hKey, _
dwIndex, _
ByVal lpValueName, _
lpcbValueName, _
0&, _
REG_DWORD, _
ByVal lpData, _
lpcbData)
If lngResult = ERROR_SUCCESS Then
strResult = Left(lpValueName, lpcbValueName)
DSNCombo.AddItem strResult
End If
dwIndex = dwIndex + 1
Loop While lngResult = ERROR_SUCCESS
RegCloseKey hKey
End Sub
|
RDO Tables
为了进入RDO，我在"Microsoft Remote Data Objects 2.0"上添加了一个reference.这个子程序创立了与数据库的连接，而且为Table ComboBox.命名了每个Table 的
名称
Private Sub FillTableCombo()
'-- Find all the table names using RDO
On Error GoTo DSNTablesError
Dim myEnviroment As rdoEnvironment
Dim myConnection As rdoConnection
Dim strUID As String
Dim strPWD As String
strUID = PropertyForm.UserNameText
strPWD = PropertyForm.PasswordText
Set myEnviroment = rdoEngine.rdoEnvironments(0)
Set myConnection = myEnviroment.OpenConnection(PropertyForm.DSNCombo.Text, _
Connect:="uid=" & strUID & "; pwd=" & strPWD & ";")
TableCombo.Clear
For Each tb In myConnection.rdoTables
TableCombo.AddItem tb.Name
Next
'-- Clear Fields to avoid mismatched data
FieldCombo.Clear
myConnection.Close
myEnviroment.Close
DSNTablesError:
End Sub
|
ADODB Fields
与其为ADODB作一个reference，不如通过objects来存取。此子程序将ComboBox作为一个变量参数，可以用来更新Database properties上的Field combo和Secondary Field Combo.。
Fill Field Combo使用DNS 及 Table combo boxes提供的信息来打开表格。当型循环会扫描每个域名并将此添加到Field combo上。
Private Sub FillFieldCombo(myCombo As ComboBox)
'-- myCombo - the ComboBox that is to be updated by the subroutine
On Error GoTo DSNTablesError
'--Populate the field combo using ADODB
Dim oTempConnection As Object
Dim oTable As Object
Dim intCount As Integer
Dim intNumOfFields As Integer
Set oTempConnection = CreateObject("ADODB.Connection")
oTempConnection.Open PropertyForm.DSNCombo.Text, _
PropertyForm.UserNameText, PropertyForm.PasswordText
Set oTable = CreateObject("ADODB.RecordSet")
Set oTable.ActiveConnection = oTempConnection
oTable.Source = "SELECT * FROM " & PropertyForm.TableCombo
oTable.Open
intNumOfFields = oTable.Fields.Count
myCombo.Clear
While (intCount < intNumOfFields)
myCombo.AddItem oTable.Fields(intCount).Name
intCount = intCount + 1
Wend
oTable.Close
oTempConnection.Close
Exit Sub
DSNTablesError:
MsgBox "Invalid Table Name"
End Sub
|
Outlook Objects
FillFolderCombo和FillMailboxCombo 子程序非常类似。都是通过开启至OUTLOOK的连接以及增加combos来运作的。FillMailboxCombo：当用户登入另外的邮箱，则会被默认为是Outlook里的最上层文件夹；FillFolderCombo则是进入专门的邮箱的子文件夹并增加Folder combo。
Private Sub FillFolderCombo()
On Error GoTo Err_Folder
' 'Put the names of all available folders in the folderCombo
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Dim mystr As String
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
FolderCombo.Clear
mystr = MailboxCombo
While iCount <= olNamespace.folders(mystr).folders.Count
FolderCombo.AddItem olNamespace.folders(mystr).folders(iCount).Name
iCount = iCount + 1
Wend
Exit Sub
Err_Folder:
MsgBox "Unable to resolve mailbox"
End Sub
Private Sub FillMailboxCombo()
'--Fill in all the names of available mailboxes
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
MailboxCombo.Clear
While iCount <= olNamespace.folders.Count
MailboxCombo.AddItem olNamespace.folders(iCount).Name
iCount = iCount + 1
Wend
End Sub
|
修改和获得注册表设置
下面是Property form和Apply button's on-click的部份代码。
'-- Property form load event
'-- Load all registry settings
DSNCombo = GetSetting("EmailMaker", "Database", "DSN", "OLE_DB_NWind_Jet")
TableCombo = GetSetting("EmailMaker", "Database", "Table", "Customers")
FieldCombo.Text = GetSetting("EmailMaker", "Database", "Field", "ContactName")
UserNameText = GetSetting("EmailMaker", "Database", "User Name", "")
PasswordText = GetSetting("EmailMaker", "Database", "Password", "")
MailboxCombo = GetSetting("EmailMaker", "Mailbox", "Mailbox", "Mailbox - NorthWind")
FolderCombo = GetSetting("EmailMaker", "Mailbox", "Folder", "Drafts")
FromText = GetSetting("EmailMaker", "Mailbox", "From", "NorthWind")
SecondaryOption = GetSetting("EmailMaker", "Secondary", "On", 0)
SecondFieldCombo.Text = GetSetting("EmailMaker", "Secondary", "Field", "")
'-- Apply button's OnClick event
Private Sub cmdApply_Click()
'-- Save all settings to registry
SaveSetting "EmailMaker", "Database", "DSN", DSNCombo.Text
SaveSetting "EmailMaker", "Database", "Table", TableCombo.Text
SaveSetting "EmailMaker", "Database", "Field", FieldCombo.Text
SaveSetting "EmailMaker", "Database", "User Name", UserNameText
SaveSetting "EmailMaker", "Database", "Password", PasswordText
SaveSetting "EmailMaker", "Mailbox", "Mailbox", MailboxCombo
SaveSetting "EmailMaker", "Mailbox", "Folder", FolderCombo
SaveSetting "EmailMaker", "Mailbox", "From", FromText
SaveSetting "EmailMaker", "Secondary", "On", SecondaryOption
SaveSetting "EmailMaker", "Secondary", "Field", SecondFieldCombo.Text
'-- Reinitialize the main form
MDIMain.Initialize
'-- Disable the Apply button
cmdApply.Enabled = False
End Sub
|
当用户选择了数据库，程序就会使用RDO指令来专门化数据库以验证它们的table：然后，增加应用程序的table combo box，通过此，用户可以选择适当的table。最后，通过适当的table，ADODB指令会寻找到table的Field以便在"Fields" combo box上增加适当的域名。
下面是RDO TABLES 代码
API Call to registry
Public Const HKEY_CURRENT_USER = &H80000001
Public Const ERROR_SUCCESS = 0&
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_READ = &H20000
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And _
(Not SYNCHRONIZE))
Public Const REG_DWORD = 4
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" _
(ByVal hKey As Long, _
ByVal lpSubKey As String, _
ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" _
Alias "RegEnumValueA" _
(ByVal hKey As Long, _
ByVal dwIndex As Long, _
ByVal lpValueName As String, _
lpcbValueName As Long, _
ByVal lpReserved As Long, _
lpType As Long, _
lpData As Any, _
lpcbData As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
'-- The subroutine FillODBCCombo is called when the Properties form is loaded.
'-- First the root ODBC key is opened. By iterating through its sub-keys,
'-- all of the installed DNS's are found and inserted into the DNS ComboBox.
Public Sub FillODBCCombo()
'-- Load in names of all installed ODBC database (From registry)
Dim hKey As Long
Dim dwIndex As Long
Dim lpData As Long
Dim lpcbData As Long
Dim lngResult As Long
Dim strResult As String
Dim lpValueName As String
Dim lpcbValueName As Long
'-- Each ODBC Data source has a key located in
'-- HKEY_CURRENT_USER\Software\ODBC\ODBC.INI\ODBC Data Sources.
'-- By finding the name of each key, we can gather all the DNS's of
'-- the installed ODBC databases for the current user
lngResult = RegOpenKeyEx(HKEY_CURRENT_USER, _
"Software\ODBC\ODBC.INI\ODBC Data Sources", _
0&, _
KEY_READ, _
hKey)
If lngResult <> ERROR_SUCCESS Then
MsgBox "Error opening ODBC registry key."
Exit Sub
End If
dwIndex = 0
'-- Add each DNS to the combo
Do
lpcbValueName = 1000
lpcbData = 1000
lpValueName = String(lpcbValueName, 0)
'-- The RegEnumValue function allows you to
'-- move through the subkeys one at a time
lngResult = RegEnumValue(hKey, _
dwIndex, _
ByVal lpValueName, _
lpcbValueName, _
0&, _
REG_DWORD, _
ByVal lpData, _
lpcbData)
If lngResult = ERROR_SUCCESS Then
strResult = Left(lpValueName, lpcbValueName)
DSNCombo.AddItem strResult
End If
dwIndex = dwIndex + 1
Loop While lngResult = ERROR_SUCCESS
RegCloseKey hKey
End Sub
|
RDO Tables
Private Sub FillTableCombo()
'-- Find all the table names using RDO
On Error GoTo DSNTablesError
Dim myEnviroment As rdoEnvironment
Dim myConnection As rdoConnection
Dim strUID As String
Dim strPWD As String
strUID = PropertyForm.UserNameText
strPWD = PropertyForm.PasswordText
Set myEnviroment = rdoEngine.rdoEnvironments(0)
Set myConnection = myEnviroment.OpenConnection(PropertyForm.DSNCombo.Text, _
Connect:="uid=" & strUID & "; pwd=" & strPWD & ";")
TableCombo.Clear
For Each tb In myConnection.rdoTables
TableCombo.AddItem tb.Name
Next
'-- Clear Fields to avoid mismatched data
FieldCombo.Clear
myConnection.Close
myEnviroment.Close
DSNTablesError:
End Sub
|
ADODB Fields
Private Sub FillFieldCombo(myCombo As ComboBox)
'-- myCombo - the ComboBox that is to be updated by the subroutine
On Error GoTo DSNTablesError
'--Populate the field combo using ADODB
Dim oTempConnection As Object
Dim oTable As Object
Dim intCount As Integer
Dim intNumOfFields As Integer
Set oTempConnection = CreateObject("ADODB.Connection")
oTempConnection.Open PropertyForm.DSNCombo.Text, _
PropertyForm.UserNameText, PropertyForm.PasswordText
Set oTable = CreateObject("ADODB.RecordSet")
Set oTable.ActiveConnection = oTempConnection
oTable.Source = "SELECT * FROM " & PropertyForm.TableCombo
oTable.Open
intNumOfFields = oTable.Fields.Count
myCombo.Clear
While (intCount < intNumOfFields)
myCombo.AddItem oTable.Fields(intCount).Name
intCount = intCount + 1
Wend
oTable.Close
oTempConnection.Close
Exit Sub
DSNTablesError:
MsgBox "Invalid Table Name"
End Sub
|
Outlook Objects
Private Sub FillFolderCombo()
On Error GoTo Err_Folder
' 'Put the names of all available folders in the folderCombo
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Dim mystr As String
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
FolderCombo.Clear
mystr = MailboxCombo
While iCount <= olNamespace.folders(mystr).folders.Count
FolderCombo.AddItem olNamespace.folders(mystr).folders(iCount).Name
iCount = iCount + 1
Wend
Exit Sub
Err_Folder:
MsgBox "Unable to resolve mailbox"
End Sub
|
Private Sub FillMailboxCombo()
'--Fill in all the names of available mailboxes
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
MailboxCombo.Clear
While iCount <= olNamespace.folders.Count
MailboxCombo.AddItem olNamespace.folders(iCount).Name
iCount = iCount + 1
Wend
End Sub
|
获得和修改注册表设置
'-- Property form load event
'-- Load all registry settings
DSNCombo = GetSetting("EmailMaker", "Database", "DSN", "OLE_DB_NWind_Jet")
TableCombo = GetSetting("EmailMaker", "Database", "Table", "Customers")
FieldCombo.Text = GetSetting("EmailMaker", "Database", "Field", "ContactName")
UserNameText = GetSetting("EmailMaker", "Database", "User Name", "")
PasswordText = GetSetting("EmailMaker", "Database", "Password", "")
MailboxCombo = GetSetting("EmailMaker", "Mailbox", "Mailbox", "Mailbox - NorthWind")
FolderCombo = GetSetting("EmailMaker", "Mailbox", "Folder", "Drafts")
FromText = GetSetting("EmailMaker", "Mailbox", "From", "NorthWind")
SecondaryOption = GetSetting("EmailMaker", "Secondary", "On", 0)
SecondFieldCombo.Text = GetSetting("EmailMaker", "Secondary", "Field", "")
'-- Apply button's OnClick event
Private Sub cmdApply_Click()
'-- Save all settings to registry
SaveSetting "EmailMaker", "Database", "DSN", DSNCombo.Text
SaveSetting "EmailMaker", "Database", "Table", TableCombo.Text
SaveSetting "EmailMaker", "Database", "Field", FieldCombo.Text
SaveSetting "EmailMaker", "Database", "User Name", UserNameText
SaveSetting "EmailMaker", "Database", "Password", PasswordText
SaveSetting "EmailMaker", "Mailbox", "Mailbox", MailboxCombo
SaveSetting "EmailMaker", "Mailbox", "Folder", FolderCombo
SaveSetting "EmailMaker", "Mailbox", "From", FromText
SaveSetting "EmailMaker", "Secondary", "On", SecondaryOption
SaveSetting "EmailMaker", "Secondary", "Field", SecondFieldCombo.Text
'-- Reinitialize the main form
MDIMain.Initialize
'-- Disable the Apply button
cmdApply.Enabled = False
End Sub
|
以下是ADODB FIELDS 代码：
Private Sub FillFolderCombo()
On Error GoTo Err_Folder
' 'Put the names of all available folders in the folderCombo
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Dim mystr As String
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
FolderCombo.Clear
mystr = MailboxCombo
While iCount <= olNamespace.folders(mystr).folders.Count
FolderCombo.AddItem olNamespace.folders(mystr).folders(iCount).Name
iCount = iCount + 1
Wend
Exit Sub
Err_Folder:
MsgBox "Unable to resolve mailbox"
End Sub
|
Private Sub FillMailboxCombo()
'--Fill in all the names of available mailboxes
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
MailboxCombo.Clear
While iCount <= olNamespace.folders.Count
MailboxCombo.AddItem olNamespace.folders(iCount).Name
iCount = iCount + 1
Wend
End Sub
|
代码：
Private Sub FillFolderCombo()
On Error GoTo Err_Folder
' 'Put the names of all available folders in the folderCombo
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Dim mystr As String
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
FolderCombo.Clear
mystr = MailboxCombo
While iCount <= olNamespace.folders(mystr).folders.Count
FolderCombo.AddItem olNamespace.folders(mystr).folders(iCount).Name
iCount = iCount + 1
Wend
Exit Sub
Err_Folder:
MsgBox "Unable to resolve mailbox"
End Sub
|
Private Sub FillMailboxCombo()
'--Fill in all the names of available mailboxes
Dim myOlApp As Object
Dim olNamespace As Object
Dim iCount As Integer
Set myOlApp = CreateObject("Outlook.Application")
Set olNamespace = myOlApp.GetNameSpace("MAPI")
iCount = 1
MailboxCombo.Clear
While iCount <= olNamespace.folders.Count
MailboxCombo.AddItem olNamespace.folders(iCount).Name
iCount = iCount + 1
Wend
End Sub
|
在此程序里，我创建了Message Properties对话框，以便让用户可以创建或修改"from" field。虽然我没有找出一个行之有效的办法来增加所有有效的地址选择，但是，Sent From的设置在Message Properties 对话框里也是一个可进入的域。
在Message Editing窗口里有个比较奇怪的现象。当在Message Editing窗口内找开一个message时，窗口的图标会是一个合上的信封。当修改或编辑message旱，图标则会变成有支笔放在信封上的图案。然后，当保存时，图标又会变成合上的信封。这项功能帮助用户了解到是不是自上一次编辑以来对文件有所保存。这个功能运行稳定，除了当Message Editing窗口最大化时。当窗口最大化时，图标则不会改变，我也没有找出为什么会发生这种现象的源由。
|
