发表评论(0)作者:不详, 平台:VB6.0+Win98, 阅读:8067, 日期: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
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