vb設計數據庫電子郵件程序-ShareBody資訊站

vb設計數據庫電子郵件程序

問題的產生

Interface Technologies (ITI)的CodeVizor工作組正在努力使他們的新工具引起程序員的注意。在先前的數個月里，成千上萬的程序員注冊成為ITI's DevCentral的一員，以更方便的試用它們的產品。作為注冊的一部份，注冊者被詢問到他們是否希望得到產品的更新及新產品發布的消息。幾乎所有的注冊者都希望如此。

因此，工作團隊決定向所有六千名注冊用戶發送一封個人電子郵件信息（當然得除開那些沒有留聯系EMail的用戶）。但是這就出現了個問題：如果是發群體信件，則就違背了發個人郵件的初衷。我們希望的是發往注冊用戶的郵件是個人化的。因此，我們就得找出一種解決辦法，使得發向6000名注冊用戶的群體郵件是完全個人的，保密的。

目的

我的工作則是寫出一個程序，使得它能夠進入到DevCentral的注冊用戶的SQL Server數據庫里，然后為每個用戶生成一封電子郵件（通過Exchange/Outlook）。

該程序會將待發的EMail保存至outlook，因此就可以組織郵件發送的過程。最好是小批量發送電子郵件，一次發送500封比較合適。這樣就可以令到使用者將錯誤率降到最低，同樣也可以降低服務器的負擔，加快網絡連接速度。同樣我們需在郵件上加上回復地址，這樣郵件則可以從DevCentral的郵箱里發出，而不是個人的郵箱。

以下將是創建該程序的主要步驟

使用工具及使用目的

通過使用Visual Basic 5.0寫出該EmailMaker。該應用程序通過ODBC來進入數據庫，并使用VBautomation調用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_USERSoftwareODBCODBC.INIODBC Data Sources.上
'-- 通過查找每個關鍵字，能夠收集到安裝在ODBC上的所有數據源

lngResult = RegOpenKeyEx(HKEY_CURRENT_USER, _
"SoftwareODBCODBC.INIODBC 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_USERSoftwareODBCODBC.INIODBC 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, _
"SoftwareODBCODBC.INIODBC 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

ADODB Fields

Outlook Objects

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

獲得和修改注冊表設置

以下是ADODB FIELDS 代碼：

代碼：

在此程序里，我創建了Message Properties對話框，以便讓用戶可以創建或修改"from" field。雖然我沒有找出一個行之有效的辦法來增加所有有效的地址選擇，但是，Sent From的設置在Message Properties 對話框里也是一個可進入的域。

在Message Editing窗口里有個比較奇怪的現象。當在Message Editing窗口內找開一個message時，窗口的圖標會是一個合上的信封。當修改或編輯message旱，圖標則會變成有支筆放在信封上的圖案。然后，當保存時，圖標又會變成合上的信封。這項功能幫助用戶了解到是不是自上一次編輯以來對文件有所保存。這個功能運行穩定，除了當Message Editing窗口最大化時。當窗口最大化時，圖標則不會改變，我也沒有找出為什么會發生這種現象的源由。

【責任編輯：方舟 頻道主編：趙家雄】

作者：http://www.zhujiangroad.com

來源：http://www.zhujiangroad.com

※以上資訊由網路資料整理而成，若有遺誤概以來源為準，本站不負任何相關責任。

※如果您認為網站上資訊侵犯了您的版權，請告訴我們按這裡，我們將即時將您的版權資料移除。

網頁語言教學

程式語言教學

移動端教學

資料庫

生活資訊

法拍資訊

實價登錄