frm_start.frm

本系统为客户管理系统 (1)本系统的数据库为SQL Server 2000

VERSION 5.00
Begin VB.Form Frm_Start 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   3270
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5085
   LinkTopic       =   "Form1"
   ScaleHeight     =   3270
   ScaleWidth      =   5085
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox Picture1 
      BorderStyle     =   0  'None
      Height          =   3300
      Left            =   0
      Picture         =   "Frm_Start.frx":0000
      ScaleHeight     =   3300
      ScaleWidth      =   5130
      TabIndex        =   0
      Top             =   -15
      Width           =   5130
      Begin VB.Timer Timer1 
         Interval        =   500
         Left            =   435
         Top             =   2640
      End
   End
End
Attribute VB_Name = "Frm_Start"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _
    "GetVolumeInformationA" (ByVal lpRootPathName As String, _
    ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, _
    lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
    lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
    ByVal nFileSystemNameSize As Long) As Long
    '创建注册表项
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 RegSetValueEx Lib "advapi32.dll" Alias _
   "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, _
   ByVal cbData As Long) As Long
   '打开注册表中的项
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
Const REG_SZ = 1
Const REG_DWORD = 4
Const HKEY_CURRENT_USER = &H80000001
Dim fso, txtfile
Dim mySerial As Long
Dim mylong As Long
'提取计算机名和用户名
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
  '提取系统目录
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
  Dim hKey As Long
  Dim strLong As String * 256
  Dim s As String * 100
  Dim Length As Long
  Dim WinPath As String
  Dim SysPath As String

'附加数据库定义
Private con As New ADODB.Connection
Private rs As New ADODB.Recordset
Private rsDropDB As New ADODB.Recordset
Private rsSql As New ADODB.Recordset
Private str As String, Source As String, SourceM As String, SourceL As String

'设置窗口可移动
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1




Sub Step()
'配置数据源*********************************************
  '提取SQL驱动
  Length = GetSystemDirectory(s, Len(s))
  SysPath = Left(s, Length)
  Dim Lab As String
  Lab = SysPath + "\sqlsrv32.dll"

    '提取计算机名称和用户名
    Dim txtUserName As String
    GetUserName strLong, 255
    txtUserName = strLong
    strLong = Trim(strLong)

    '向创建ODBC数据源
    RegOpenKeyEx HKEY_CURRENT_USER, "Software\ODBC\ODBC.INI", 0, 0, hKey
    RegCreateKey HKEY_CURRENT_USER, "Software\ODBC\ODBC.INI\db_Client", hKey
    RegSetValueEx hKey, "Database", 0, REG_SZ, ByVal "db_Client", Len("db_Client")
    RegSetValueEx hKey, "Driver", 0, REG_SZ, ByVal Lab, Len(Lab)
    RegSetValueEx hKey, "LastUser", 0, REG_SZ, ByVal txtUserName, Len(txtUserName)
    RegSetValueEx hKey, "Server", 0, REG_SZ, ByVal "(local)", 7
    RegSetValueEx hKey, "Trusted_Connection", 0, REG_SZ, ByVal "Yes", 3
    '驱动Server ODBC数据源
    RegOpenKeyEx HKEY_CURRENT_USER, "Software\ODBC\ODBC.INI\ODBC Data Sources", 0, 0, hKey
    RegCreateKey HKEY_CURRENT_USER, "Software\ODBC\ODBC.INI\ODBC Data Sources", hKey
    RegSetValueEx hKey, "db_Client", 0, REG_SZ, ByVal "SQL Server", 10
    For i = 1 To 3
        Call AddData
    Next i
End Sub
Sub AddData()
   SourceM = MyPath(App.Path, "窗体")
   SourceM = SourceM & "Database\db_Client_Data.MDF"
   SourceL = MyPath(App.Path, "窗体")
   SourceL = SourceL & "Database\db_Client_Log.LDF"
   '附加数据库********************************************
      Set con = New ADODB.Connection
      con.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa"
   On Error Resume Next
     Set rs = New ADODB.Recordset
         str = "EXEC sp_attach_db @dbname = N'db_Client', @filename1 = N'" + SourceM + "', @filename2 = N'" + SourceL + "'"
        Set rs = con.Execute(str)

   Dim cn As New ADODB.Connection
   cn.Open "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=db_Client"
   If Err.Number = -2147217900 Then              '捕捉错误号
      Frm_mm.Show
      Unload Me
   Else
      '如果数据库出现质疑 问题 将其移除
      rsDropDB.Open "DROP DATABASE db_Client", con, adOpenDynamic, adLockOptimistic
      rsDropDB.Close
   End If
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
  X = ReleaseCapture
  returnva = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub

Private Sub Timer1_Timer()
  Call Step
End Sub