frm_start.frm

PMS是一个生产管理系统,功能强大,供大家享用,希望大家支持!!

VERSION 5.00
Begin VB.Form Frm_Start 
   BorderStyle     =   0  'None
   ClientHeight    =   3240
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5100
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3240
   ScaleWidth      =   5100
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox Picture1 
      BorderStyle     =   0  'None
      Height          =   3285
      Left            =   0
      Picture         =   "Frm_Start.frx":0000
      ScaleHeight     =   3285
      ScaleWidth      =   5160
      TabIndex        =   0
      Top             =   0
      Width           =   5160
      Begin VB.Timer Timer1 
         Interval        =   500
         Left            =   750
         Top             =   2250
      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

Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1
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

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_SCGL", hKey
    RegSetValueEx hKey, "Database", 0, REG_SZ, ByVal "db_SCGL", Len("db_SCGL")
    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_SCGL", 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_SCGL_Data.MDF"
   SourceL = MyPath(App.Path, "窗体")
   SourceL = SourceL & "Database\db_SCGL_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_SCGL', @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_SCGL"
   If Err.Number = -2147217900 Then              '捕捉错误号
      Frm_mm.Show
      Unload Me
   Else
      '如果数据库出现质疑 问题 将其移除
      rsDropDB.Open "DROP DATABASE db_SCGL", 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()
  ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End If
End Sub

Private Sub Timer1_Timer()
  Call Step
End Sub