dapp.frm

一个演示如何根据数据库动态建立访问数据库的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)
    
    
    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 Sub

Private 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 If

End Sub