在程序中动态创建DSN数据源: VERSION 5.00 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx" Begin VB.Form DAPP BackColor = &H00C00000& Caption = "DSN ON THE FLY TIENET TECHNOLOGIES ,CHENNAI,INDIA" ClientHeight = 4410 ClientLeft = 2220 ClientTop = 3285 ClientWidth = 9585 FillStyle = 2 'Horizontal Line FontTransparent = 0 'False Icon = "DAPP.frx":0000 KeyPreview = -1 'True MaxButton = 0 'False MouseIcon = "DAPP.frx":030A Palette = "DAPP.frx":0BD4 Picture = "DAPP.frx":2446 ScaleHeight = 220.5 ScaleMode = 2 'Point ScaleWidth = 479.25 StartUpPosition = 2 'CenterScreen WhatsThisButton = -1 'True WhatsThisHelp = -1 'True Begin VB.TextBox DSN BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 735 Left = 4200 TabIndex = 1 Tag = "1" Text = "Data Source Name" Top = 1920 Width = 3375 End Begin VB.CommandButton CreateDSN Caption = "Create Data Source Name (ACCESS DATABASE)" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 735 Left = 2040 MaskColor = &H00FFFFC0& TabIndex = 4 Tag = "3" ToolTipText = "Create Data Source Name" Top = 3480 UseMaskColor = -1 'True Width = 5655 End Begin VB.TextBox DatabaseName BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 615 Left = 4200 Locked = -1 'True TabIndex = 0 Tag = "0" Top = 1080 Width = 3375 End Begin VB.CommandButton Browse BackColor = &H00FFFFC0& Caption = "Browse" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 615 Left = 7560 MaskColor = &H00FFFFC0& TabIndex = 2 Tag = "2" Top = 1080 Width = 1935 End Begin MSComDlg.CommonDialog xDialog Left = 8160 Top = 3720 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.Image Image1 Height = 1020 Left = 0 Picture = "DAPP.frx":3CB8 Top = 0 Width = 1140 End Begin VB.Label Label3 Alignment = 2 'Center BackColor = &H00C00000& Caption = "Create DSN On the Fly" BeginProperty Font Name = "MS Serif" Size = 18 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H8000000E& Height = 615 Left = 1560 TabIndex = 6 Top = 120 Width = 7695 End Begin VB.Label Label2 BackColor = &H00C00000& Caption = "Enter The Data Source Name" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H8000000E& Height = 735 Left = 120 TabIndex = 5 Top = 1920 Width = 4095 End Begin VB.Label Label1 BackColor = &H00C00000& Caption = "Select A Database" BeginProperty Font Name = "MS Sans Serif" Size = 12 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H8000000E& Height = 615 Left = 120 TabIndex = 3 Top = 1080 Width = 4095 End End
Attribute VB_Name = "DAPP" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Const KEY_QUERY_VALUE = &H1 Private Const ERROR_SUCCESS = 0& Private Const REG_SZ = 1 Private Const HKEY_LOCAL_MACHINE = &H80000002 Private Const REG_DWORD = 4 Dim strFilename As String Private 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 Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value. Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long Public Function createAccessDSN(szDriverName As String, szWantedDSN As String, dbvalue As String) As Boolean Dim hKey As Long Dim szKeyPath As String Dim szKeyName As String Dim szKeyValue As String Dim lKeyValue As Long Dim lRes As Long Dim lSize As Long Dim szEmpty As String szEmpty = Chr(0)
lRes = RegCloseKey(hKey) lRes = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKey)
If lRes <> ERROR_SUCCESS Then createAccessDSN = False Exit Function End If
szKeyValue = "Microsoft Access Driver (*.mdb)" lRes = RegSetValueExString(hKey, szWantedDSN, 0&, REG_SZ, szKeyValue, Len(szKeyValue)) lRes = RegCloseKey(hKey) createAccessDSN = True End Function Private Sub Browse_Click() Dim oDialog As Object Set oDialog = DAPP.xDialog.Object ' Ask for new file location. oDialog.DialogTitle = "Please Select New Data File" oDialog.Filter = "Access Database(*.mdb;*.mda;*.mde;*.mdw)|*.mdb; *.mda; *.mde; *.mdw|All(*.*)|*.*" oDialog.FilterIndex = 1 oDialog.ShowOpen ' If user responded, put selection into text box on form. If Len(oDialog.FileName) > 0 Then DAPP.DatabaseName = oDialog.FileName strFilename = DAPP.DatabaseName End If End SubPrivate Sub CreateDSN_Click() Dim dsnname As String dsnname = DAPP.DSN If Not (dsname = "" And strFilename = "") Then createAccessDSN "Microsoft Access Driver (*.mdb)", dsnname, strFilename MsgBox ("DSN" & dsnname & "Created Sucessfully") Else If dsnname = "" Then MsgBox ("Please Enter A Data Source Name") Exit Sub End If If strFilename = "" Then MsgBox ("Please Select a Database") Exit Sub End If End IfEnd Sub
http://www.csdn.net/expert/topic/586/586545.xml?temp=.4769098
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form DAPP
BackColor = &H00C00000&
Caption = "DSN ON THE FLY TIENET TECHNOLOGIES ,CHENNAI,INDIA"
ClientHeight = 4410
ClientLeft = 2220
ClientTop = 3285
ClientWidth = 9585
FillStyle = 2 'Horizontal Line
FontTransparent = 0 'False
Icon = "DAPP.frx":0000
KeyPreview = -1 'True
MaxButton = 0 'False
MouseIcon = "DAPP.frx":030A
Palette = "DAPP.frx":0BD4
Picture = "DAPP.frx":2446
ScaleHeight = 220.5
ScaleMode = 2 'Point
ScaleWidth = 479.25
StartUpPosition = 2 'CenterScreen
WhatsThisButton = -1 'True
WhatsThisHelp = -1 'True
Begin VB.TextBox DSN
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 735
Left = 4200
TabIndex = 1
Tag = "1"
Text = "Data Source Name"
Top = 1920
Width = 3375
End
Begin VB.CommandButton CreateDSN
Caption = "Create Data Source Name (ACCESS DATABASE)"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 735
Left = 2040
MaskColor = &H00FFFFC0&
TabIndex = 4
Tag = "3"
ToolTipText = "Create Data Source Name"
Top = 3480
UseMaskColor = -1 'True
Width = 5655
End
Begin VB.TextBox DatabaseName
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 4200
Locked = -1 'True
TabIndex = 0
Tag = "0"
Top = 1080
Width = 3375
End
Begin VB.CommandButton Browse
BackColor = &H00FFFFC0&
Caption = "Browse"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 615
Left = 7560
MaskColor = &H00FFFFC0&
TabIndex = 2
Tag = "2"
Top = 1080
Width = 1935
End
Begin MSComDlg.CommonDialog xDialog
Left = 8160
Top = 3720
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Image Image1
Height = 1020
Left = 0
Picture = "DAPP.frx":3CB8
Top = 0
Width = 1140
End
Begin VB.Label Label3
Alignment = 2 'Center
BackColor = &H00C00000&
Caption = "Create DSN On the Fly"
BeginProperty Font
Name = "MS Serif"
Size = 18
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000E&
Height = 615
Left = 1560
TabIndex = 6
Top = 120
Width = 7695
End
Begin VB.Label Label2
BackColor = &H00C00000&
Caption = "Enter The Data Source Name"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000E&
Height = 735
Left = 120
TabIndex = 5
Top = 1920
Width = 4095
End
Begin VB.Label Label1
BackColor = &H00C00000&
Caption = "Select A Database"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H8000000E&
Height = 615
Left = 120
TabIndex = 3
Top = 1080
Width = 4095
End
End
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const KEY_QUERY_VALUE = &H1
Private Const ERROR_SUCCESS = 0&
Private Const REG_SZ = 1
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const REG_DWORD = 4
Dim strFilename As String
Private 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
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Public Function createAccessDSN(szDriverName As String, szWantedDSN As String, dbvalue As String) As Boolean
Dim hKey As Long
Dim szKeyPath As String
Dim szKeyName As String
Dim szKeyValue As String
Dim lKeyValue As Long
Dim lRes As Long
Dim lSize As Long
Dim szEmpty As String
szEmpty = Chr(0)
lSize = 4
lRes = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN, hKey)
If lRes <> ERROR_SUCCESS Then
createAccessDSN = False
Exit Function
End If
lRes = RegSetValueExString(hKey, "UID", 0&, REG_SZ, szEmpty, Len(szEmpty))
szKeyValue = dbvalue
lRes = RegSetValueExString(hKey, "DBQ", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
szKeyValue = szDriverName
lRes = RegSetValueExString(hKey, "Driver", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
szKeyValue = "MS Access;"
lRes = RegSetValueExString(hKey, "FIL", 0&, REG_SZ, _
szKeyValue, Len(szKeyValue))
lKeyValue = 25
lRes = RegSetValueExLong(hKey, "DriverId", 0&, REG_DWORD, _
lKeyValue, 4)
lKeyValue = 0
lRes = RegSetValueExLong(hKey, "SafeTransactions", 0&, REG_DWORD, _
lKeyValue, 4)
lRes = RegCloseKey(hKey)
szKeyPath = "SOFTWARE\ODBC\ODBC.INI\" & szWantedDSN & "\Engines\Jet"
lRes = RegCreateKey(HKEY_LOCAL_MACHINE, szKeyPath, hKey)
If lRes <> ERROR_SUCCESS Then
createAccessDSN = False
Exit Function
End If
lRes = RegSetValueExString(hKey, "ImplicitCommitSync", 0&, REG_SZ, szEmpty, Len(szEmpty))
szKeyValue = "Yes"
lRes = RegSetValueExString(hKey, "UserCommitSync", 0&, REG_SZ, szKeyValue, Len(szKeyValue))
lKeyValue = 2048
lRes = RegSetValueExLong(hKey, "MaxBufferSize", 0&, REG_DWORD, lKeyValue, 4)
lKeyValue = 5
lRes = RegSetValueExLong(hKey, "PageTimeout", 0&, REG_DWORD, lKeyValue, 4)
lKeyValue = 3
lRes = RegSetValueExLong(hKey, "Threads", 0&, REG_DWORD, lKeyValue, 4)
lRes = RegCloseKey(hKey)
lRes = RegCreateKey(HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources", hKey)
If lRes <> ERROR_SUCCESS Then
createAccessDSN = False
Exit Function
End If
szKeyValue = "Microsoft Access Driver (*.mdb)"
lRes = RegSetValueExString(hKey, szWantedDSN, 0&, REG_SZ, szKeyValue, Len(szKeyValue))
lRes = RegCloseKey(hKey)
createAccessDSN = True
End Function
Private Sub Browse_Click()
Dim oDialog As Object
Set oDialog = DAPP.xDialog.Object
' Ask for new file location.
oDialog.DialogTitle = "Please Select New Data File"
oDialog.Filter = "Access Database(*.mdb;*.mda;*.mde;*.mdw)|*.mdb; *.mda; *.mde; *.mdw|All(*.*)|*.*"
oDialog.FilterIndex = 1
oDialog.ShowOpen
' If user responded, put selection into text box on form.
If Len(oDialog.FileName) > 0 Then
DAPP.DatabaseName = oDialog.FileName
strFilename = DAPP.DatabaseName
End If
End SubPrivate Sub CreateDSN_Click()
Dim dsnname As String
dsnname = DAPP.DSN
If Not (dsname = "" And strFilename = "") Then
createAccessDSN "Microsoft Access Driver (*.mdb)", dsnname, strFilename
MsgBox ("DSN" & dsnname & "Created Sucessfully")
Else
If dsnname = "" Then
MsgBox ("Please Enter A Data Source Name")
Exit Sub
End If
If strFilename = "" Then
MsgBox ("Please Select a Database")
Exit Sub
End If
End IfEnd Sub