VB6动态连接数据库模板

最近接到一个任务——迁移数据库

   要迁移的数据库是SQL2005数据库，有两个应用软件是与此数据库进行数据通信。由于客户端应用程序的连接数据库方式直接以绝对方式写入程序，所以此次迁移需要同时修改客户端应用程序，考虑到不久后公司地址要变动，到时还要重新配置服务器，肯定还要修客户端代码，于是我打算采用模板的方式，将应用程序修改成动态连接数据库，那么后续迁移数据将不需要修改应用程序的代码，只需要修改配置文件即可。

   思路：增加一个配置文件setup.ini，固定setup.ini的数据格式，编写一个读取setup.ini数据的模板，提取其中的服务器名、用户名、密码、数据库名等信息，通过修改ini文件来实现连接不同服务器的目的：

ini.bas的代码：

'===========================================================================
'用法：

'1、在程序所在目录建立Setup.ini

'2、在ini文件中添加如下信息：
'[Setup Information]
'Server = 服务器名
'UserName = 用户名
'Password = 密码
'Data = 数据库

'3、工程引用Microsoft Axtivex data objects 2.6 library

'4、修改ini.bas中main中修改form.Show

'5 、在需要连接数据库的窗体顶端加入以下代码:
'    Option Explicit
'    Dim Conn As New ADODB.Connection
'    Dim Rs As New ADODB.Recordset

'6、连接数据库：
'Conn.Open "driver={SQL Server};server=" + Trim(Server) + ";uid=" + Trim(User) + ";pwd=" + Trim(Password) + ";database=" + Trim(Data) + ""
'Rs.Open "select * from 表民", Conn, adOpenKeyset, adLockOptimistic

'7、退出数据库连接:
'        Rs.Close
'        Conn.Close
'        Set Rs = Nothing
'        Set Conn = Nothing

'===========================================================================


'保存执行SQL语句的字符串
'Public SqlStmt As String

'声明写入ini文件的API函数
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As Any, ByVal lpFilenchame As String) As Long
Public Declare Function WritePrivateProfileSection Lib "kernel32" Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, ByVal lpString As String, ByVal lpFilenchame As String) As Long

'定义服务器参数常量
Public Server As String
Public User As String
Public Password As String
Public Data As String

'程序进入点
Sub main()

  '从Setup.ini中读取服务器的名字
  Server = GetKey(App.Path + "Setup.ini", "Server")
  User = GetKey(App.Path + "Setup.ini", "User")
  Password = GetKey(App.Path + "Setup.ini", "Password")
  Data = GetKey(App.Path + "Setup.ini", "Data")
  '如果读取不成功，退出
  If Server = "" Then
  MsgBox "Setup.ini文件参数错误！", , "警告"
  End If
  
  '显示系统主界面
  Form1.Show

End Sub

'判断文件是否存在
Function FileExist(Fname As String) As Boolean
  On Local Error Resume Next
  FileExist = (Dir(Fname) <> "")
End Function
'读取ini文件的数据项值
Public Function GetKey(Tmp_File As String, Tmp_Key As String) As String
  Dim File As Long
  '分配文件句柄
  File = FreeFile
  
  '如果文件不存在则创建一个默认的Setup.ini文件
  If FileExist(Tmp_File) = False Then
    GetKey = ""
    Call WritePrivateProfileString("Setup Information", "Server", "", App.Path + "Setup.ini")
    Call WritePrivateProfileString("Setup Information", "UserName ", " ", App.Path + "Setup.ini")
    Call WritePrivateProfileString("Setup Information", "Password", " ", App.Path + "Setup.ini")
    Call WritePrivateProfileString("Setup Information", "Data", " ", App.Path + "Setup.ini")
    Exit Function
  End If
  
  '读取数据项值
  Open Tmp_File For Input As File
    Do While Not EOF(1)
      Line Input #File, buffer
      If Left(buffer, Len(Tmp_Key)) = Tmp_Key Then
        pos = InStr(buffer, "=")
        GetKey = Trim(Mid(buffer, pos + 1))
      End If
    Loop
  Close File
End Function

以上代码在win7+VB6+SQL2005环境中测试通过.

总结：不要把程序钉死在老地方——出自《程序员应该知道的97件事》中的第28条