发表评论(0)作者：不详, 平台：VB6.0+Win98, 阅读：7900, 日期：2001-06-14

vb设计数据库电子邮件程序
crystal编译
--------------------------------------------------------------------------------




　　下面是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