main_module.bas

采购信息录入系统,相对来说

Attribute VB_Name = "Main_Module"
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public DB As ADODB.Connection
Public rs As ADODB.Recordset
Public RS_Temp As ADODB.Recordset
Public NewNode As Node
Public Filiale_Name, Filiale_Code As String

Private Sub DataBase_Init()
    Set DB = New Connection
    DB.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=STOCK.mdb;Persist Security Info=False"
    Exit Sub
ERR:
    MsgBox "数据库连接错误！程序退出", vbOKOnly, App.EXEName
    End
End Sub

Public Sub AutoSelectText(ByRef SelObject As Control)
   '-------------------------
   '功能：  用于当焦点进入文本编辑筐时自动选择已经有的文本
   '参数：  SelObject 欲设置的控件
   '返回值:
   '用法:   在控件的GotFocus中 call AutoSelectText(欲设置的控件名)
   '建立:   2001/10/30 by reading
   '修改:
   '修改内容:
   '-------------------------
   
    SelObject.SelStart = 0
    
        If TypeOf SelObject Is TextBox Then
            SelObject.Text = Trim(SelObject)
            SelObject.SelLength = Len(SelObject.Text)
            SelObject.ToolTipText = SelObject.Text
        End If
    
End Sub

Public Sub IfEnterKeyMoveNext(ByRef KeyAscii As Integer)
   '-------------------------
   '功能：  主要是用于在控件中按回车键时焦点自动进入下一个控件
   '参数：  KeyAscii 按键的键值,该值直接由控件的KeyPress的参数传来
   '返回值:
   '用法:   在控件的KeyPress中调用IfEnterKeyMoveNext()
   '建立:   2001/10/31  by reading
   '修改:
   '修改内容:
   '-------------------------
    If KeyAscii = 13 Then
        KeyAscii = 0
        SendKeys "{tab}"
    End If
End Sub

Sub Main()
    DataBase_Init
  '  Form1.Show 1
    frmSplash.Show 1
    frmLogin.Show 1
    Frm_Stock.Show
End Sub


Public Sub ChangeColor(ByRef obj As Object, ByVal sure As Boolean)
    If sure = False Then
        obj.BackColor = &H8000000A
        obj.ForeColor = &H0&
    Else
        obj.BackColor = &HFFC0C0
        obj.ForeColor = &H8000000D
    End If
    obj.Text = ""
End Sub

Public Sub Alert(ByVal Alert_String As String)
MsgBox Alert_String, vbExclamation, App.EXEName
End Sub

Public Sub ZIP_DATABASE(ByVal DB1 As String, ByVal DB2 As String)
    Dim FS
    Set FS = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
    FS.DeleteFile "UP_LOAD.MDB", True
    Dim jro As JetEngine
BACKUP:
On Error GoTo PRODUCE
    Set jro = New jro.JetEngine
    jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=STOCK.mdb", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=UP_LOAD.mdb"
    Set DBX = New Connection
    DBX.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=UP_LOAD.mdb;Persist Security Info=False"
    Dim RECORD As ADODB.Recordset
    Set RECORD = DBX.OpenSchema(adSchemaTables)
    Dim TableName, TableType As String
    While RECORD.EOF = False
    TableName = RECORD.Fields("TABLE_NAME").value
    TableType = RECORD.Fields("TABLE_TYPE").value
    If TableType = "TABLE" And TableName <> "STOCK_INFO" Then
        Set rs = New ADODB.Recordset
        rs.CursorType = adOpenDynamic
        rs.CursorLocation = adUseClient
        rs.LockType = adLockOptimistic
        rs.ActiveConnection = DBX
        rs.Open "DROP TABLE " & TableName & ""
    End If
    RECORD.MoveNext
    Wend
    DBX.Close
   Exit Sub
PRODUCE:
    Alert (ERR.Description)
End Sub