modulemain.bas

用vb编了一个数据库程序

Attribute VB_Name = "ModuleMain"
Option Explicit
'API申明
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long

Public Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type

'全局常量定义
Public Const csDiskRemain = 10   '10M
Public Const QYBMLength = 6
Public Const CaseCodeLength = 4

'自定义类型
Public Type CompanyCase
    QYBM As String * QYBMLength
    Nsrmc As String
    Case_Code As String * 4
    Case_Name As String
    Img_Name As String
    Img_Path As String
    Img_Current_Page As Integer
    Img_Page As Integer
    Img_SSSQ As String
    Img_ImportDate As Date
    Img_IsRegister As Boolean
End Type


'磁盘剩余空间
Public Const DiskLowAlerm = 100000000

'数据库连接常量
Global Const csProvider As String = "SQLOLEDB.1"
'Global Const csConZT97  As String = "ODBC;DSN=ZT97;"
Global Const csConCaseMain As String = "Provider=SQLOLEDB.1;Persist Security Info=False;data source=(local);User ID=sa;Initial Catalog=myDoc"

'系统需要的ZT97数据表
Global Const csDJ_QYSQL As String = "SELECT QYBM,NSRMC FROM dj_qy"
Global Const csDJ_GTSQL As String = "SELECT QYBM,NSRMC FROM dj_gt"
Global Const csDJ_WZSQL As String = "SELECT QYBM,NSRMC FROM dj_wz"
Global Const csDJ_WGSQL As String = "SELECT QYBM,NSRMC FROM dj_wg"
Global Const csDJ_ZCSQL As String = "SELECT QYBM,NSRMC FROM dj_zc"
'Global Const csJK_DJ_NSR As String = "SELECT QYBM,NSRMC FROM jk_dj_nsr"

'企业类型常量
Global Const csDJ_QY As String = "内资企业"
Global Const csDJ_GT As String = "内资个体"
Global Const csDJ_ZC As String = "内资注册"
Global Const csDJ_WZ As String = "外资"
Global Const csDJ_WG As String = "外国"
Global Const csWTDZ As String = "委托代征"
Global Const csLSDJ As String = "临时登记"
Global Const csZXDJ As String = "金银首饰专项登记"

Global Const csSeperator As String = " "

'全局变量定义
Global FindExactCompany As Boolean
Global FindExactCase As Boolean

'数据库连接
Global conZT97 As ADODB.Connection
Global conCaseMain As ADODB.Connection

'纪录集
Global rstZT97 As ADODB.Recordset
Global rstCaseMain As ADODB.Recordset

'用户要操作的企业
Global CompNum As Integer
Global CaseNum As Integer
Global PageNum As Integer
Global CompanyCodeName() As String
Global CaseCodeName() As String
Global CompanyCaseType() As CompanyCase

'主窗体
Global fMainForm As frmMain
'其他窗体
Global fQueryImg As frmQueryImg
Global fCenter As frmCenter

Sub Main()

    On Error Resume Next

    If App.PrevInstance Then
        MsgBox App.EXEName & "正在运行!", vbInformation
        End
    End If
    frmSplash.Show
    frmSplash.Refresh


    '连接ZT97数据库
'    frmSplash.lblAction.Caption = "正在连接数据库..."
'    frmSplash.lblAction.Refresh
'    Set conZT97 = New ADODB.Connection
'    conZT97.Provider = csProvider
'    conZT97.CursorLocation = adUseServer
'    conZT97.ConnectionTimeout = 60
'    conZT97.Open csConZT97
    
    On Error GoTo ErrorHandler
   
    '连接新数据库:CaseMain.mdb
    frmSplash.lblAction.Caption = "正在连接本地数据库..."
    frmSplash.lblAction.Refresh
    Set conCaseMain = New ADODB.Connection
    'conCaseMain.Provider = csProvider
    'conCaseMain.CursorLocation = adUseServer
    'conCaseMain.ConnectionTimeout = 60
    conCaseMain.Open csConCaseMain
    
    frmSplash.lblAction.Caption = "正在创建应用程序对象..."
    frmSplash.lblAction.Refresh
    Set fMainForm = New frmMain
    Set fCenter = New frmCenter
    Load fMainForm
    'Load fCenter
    Unload frmSplash

    '显示主窗体
    fMainForm.Show
    
Exit Sub

ErrorHandler:
    If Err Then
        MsgBox "系统数据库未找到,请检查CaseMain.mdb文件是否存在!", vbCritical
        Err.Clear
        End
    End If

End Sub


Public Sub MakeAllCompanyTree(TreeView As TreeView)
'*********************************************************************
'功能:   在frmCenter启动时在TreeView中显示各个企业的企业编码和企业名称
'被调用: frmCenter
'*********************************************************************
On Error GoTo ErrorHandler

Dim i As Integer

Dim nodRoot As Node
Dim NodCompanyType As Node
Dim idxCompanyType As Integer

Dim NodCompany As Node
Dim IdxCompany As Integer

Dim SQL(4) As String
Dim TypeText(4) As String

Dim rstCompany As ADODB.Recordset

SQL(0) = csDJ_QYSQL
SQL(1) = csDJ_GTSQL
SQL(2) = csDJ_WZSQL
SQL(3) = csDJ_WGSQL
SQL(4) = csDJ_ZCSQL

TypeText(0) = csDJ_QY
TypeText(1) = csDJ_GT
TypeText(2) = csDJ_WZ
TypeText(3) = csDJ_WG
TypeText(4) = csDJ_ZC

'清除TreeView中原有内容
TreeView.Nodes.Clear

'设置TreeView中的连线的长度
TreeView.Indentation = 300

'添加根节点
Set nodRoot = TreeView.Nodes.Add()
nodRoot.Text = "企业总揽"

Screen.MousePointer = vbHourglass

'连接ZT97相应的表(共5个)
For i = 0 To 4
    
    '打开表
    Set rstCompany = New ADODB.Recordset
    rstCompany.Open SQL(i), conCaseMain, 1, 1 ', adCmdTableDirect
    
    '判断表是否为空
    With rstCompany
        If Not .EOF Then .MoveLast
        If Not .BOF Then .MoveFirst
        
        '添加企业类型节点
        Set NodCompanyType = TreeView.Nodes.Add(1, tvwChild)
        NodCompanyType.Text = TypeText(i)
        'NodCompanyType.Image = ""
        idxCompanyType = NodCompanyType.Index
            
        If .RecordCount > 0 Then
        
            Do Until .EOF
            
                '添加具体企业编码+企业名称
                Set NodCompany = TreeView.Nodes.Add(idxCompanyType, tvwChild)
                NodCompany.Text = !QYBM & csSeperator & !Nsrmc
                NodCompany.Tag = !QYBM
                'NodCompany.Image = "Company"
                IdxCompany = NodCompany.Index
            
                .MoveNext
            Loop
        End If
    End With
Next i

rstCompany.Close
Set rstCompany = Nothing
Screen.MousePointer = vbDefault

Exit Sub

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbExclamation
        Err.Clear
        Screen.MousePointer = vbDefault
    End If
End Sub

Public Sub MakeAllCaseTree(TreeView As TreeView)
'**********************************************
'功能:在frmCenter启动时显示所有文书编码+文书名称
'调用:frmCenter_Load
'**********************************************
On Error GoTo ErrorHandler

Dim i As Integer

Dim nodRoot As Node
Dim idxRoot As Integer

Dim nodMode As Node
Dim idxMode As Integer

Dim nodCase As Node
Dim idxCase As Integer

Dim rstCase As ADODB.Recordset

'清除TreeView中原有内容
TreeView.Nodes.Clear

With TreeView

    '建立根节点
    Set nodRoot = .Nodes.Add()
    nodRoot.Text = "文书总揽"
    
    '打开sys_Image表
    Set rstCase = New ADODB.Recordset
    rstCase.Open "Select * from Sys_Case Order by Case_Code", conCaseMain, 1, 1 ', adCmdTableDirect
    
    '检查该表是否为空
    With rstCase
        If Not .EOF Then .MoveLast
        If Not .BOF Then .MoveFirst
        If .RecordCount > 0 Then
            
            Do Until .EOF
            
                '添加文书节点
                Set nodCase = TreeView.Nodes.Add(1, tvwChild)
                nodCase.Text = !Case_Code & csSeperator & !Case_Name
                nodCase.Tag = !Case_Code
                'nodCase.Image = "Case"
                idxCase = nodCase.Index
            
                .MoveNext
            Loop
            
        End If
    End With
End With

rstCase.Close

Set rstCase = Nothing

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbExclamation
        Err.Clear
    End If
End Sub

Public Sub FindExactNode(strFind As String, LengthOfTag As Integer, TreeView As TreeView)
'**********************************************
'功能:在TreeView中查找与strFind最相近的Node
'调用:frmCenter_Load
'**********************************************

Dim i As Integer

With TreeView
    For i = 1 To .Nodes.Count
        If UCase(Left(.Nodes(i).Tag, Len(strFind))) = UCase(strFind) Then
            If Len(strFind) = QYBMLength Then
                FindExactCompany = True
                FindExactCase = False
            End If
            If Len(strFind) = CaseCodeLength Then
                FindExactCase = True
                FindExactCompany = False
            End If
            .Nodes(i).Selected = True
            Exit Sub
        End If
    Next i
End With

End Sub

Public Function TranceList(TreeView As TreeView, ListBox As ListBox, LengthOfTag As Integer) As Boolean
'******************************************************************
'功能:将TreeView中选定的Node的Text加入ListBox中
'调用:frmCenter中的tvCompany_DblClick和txtQYBM_KeyPress(vbKeyReturn)
'******************************************************************

Dim i As Integer

If Len(TreeView.SelectedItem.Tag) <> LengthOfTag Then
    TranceList = False
    Exit Function
End If

With TreeView
    For i = 0 To ListBox.ListCount - 1
        If ListBox.List(i) = .SelectedItem.Text Then
            TranceList = False
            Exit Function
        End If
    Next i
    ListBox.AddItem .SelectedItem.Text
End With

TranceList = True

End Function

Public Sub DeleteList(ListBox As ListBox, ListIndex As Integer)
'****************************************
'功能:删除ListBox中的一个List
'用于:frmCenter中的cmdOneDelete_click
'****************************************

Dim i As Integer

If ListBox.ListCount > 0 Then
    'ListBox.ListIndex = ListIndex
    For i = ListBox.ListCount - 1 To 0 Step -1
        If ListBox.Selected(i) = True Then
            ListBox.RemoveItem (i)
        End If
        'If ListBox.ListIndex > 0 Then
        '    ListBox.Selected(i - 1) = True
        'End If
    Next i
End If

End Sub