modulemain.bas

用vb编了一个数据库程序

Public Function DiskSpaceEnough(DrivePath As String) As Boolean
'**************************************************
'功能: 检查备份图片的路径所在驱动器剩余空间是否大于
'      零界值-DiskLowAlerm,该值在模块中定义
'用于: frmFileImport窗体的CmdSave_Click事件
'      frmImgImport窗体的CmdStartScan_Click事件
'**************************************************
Dim BytesPerSector As Long
Dim SectorsPerCluster As Long
Dim NumberOfFreeClusters As Long
Dim TotalNumberOfClusters As Long

GetDiskFreeSpace DrivePath, SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters
If BytesPerSector * SectorsPerCluster * NumberOfFreeClusters < DiskLowAlerm Then
    DiskSpaceEnough = False
Else
    DiskSpaceEnough = True
End If

End Function


Public Sub CheckSame(lstItem1() As String, Dimension1 As Integer, lstItem2() As String, Dimension2 As Integer, ByRef lstResult() As String)
'****************************************************************
'功能:提取两个数组中不同的项目合成一个新数组,其中的每个项目都唯一
'用于:frmCenter中的 Private sub PutIntoArrayCompany_Case()
'****************************************************************
On Error Resume Next

Dim n1 As Integer
Dim n2 As Integer
Dim nResult As Integer

Dim Dim1 As Integer
Dim Dim2 As Integer

Dim IsExisted As Boolean

Dim1 = Dimension1 - 1
Dim2 = Dimension2 - 1


'将lstItem1中的所有值都赋给lstResult()
If Dim1 >= 0 Then
    For n1 = 0 To Dim1
        ReDim Preserve lstResult(n1)
        lstResult(n1) = lstItem1(n1)
    Next n1
    nResult = Dim1 + 1
End If

'检查lstItem2中的值,如果在lstItem1()中没有,则添加给lstResult()
For n2 = 0 To Dim2
    For n1 = 0 To Dim1
        If lstItem1(n1) <> lstItem2(n2) Then
            IsExisted = False
        Else
            IsExisted = True
            Exit For
        End If
    Next n1
    If IsExisted = False Then
    
        ReDim Preserve lstResult(nResult)
        lstResult(nResult) = lstItem2(n2)
        nResult = nResult + 1
    End If
Next n2

Exit Sub

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

Public Function SaveImage(CompanyCaseType As CompanyCase) As Boolean
'**************************************************
'功能：将扫描所得图片信息或现存图片存入数据库
'调用：frmImgScan，frmImgCopy
'返回值：True -- 保存成功；False -- 失败
'**************************************************
On Error GoTo ErrorHandler

Dim rstImage As ADODB.Recordset

Set rstImage = New ADODB.Recordset
rstImage.Open "sys_Image", conCaseMain, 1, 3 ', adCmdTable
With rstImage
    'If Not .EOF Then .MoveLast
    .AddNew
    
    !QYBM = CompanyCaseType.QYBM
    !Nsrmc = CompanyCaseType.Nsrmc
    !Img_Name = CompanyCaseType.Img_Name
    !Img_Path = CompanyCaseType.Img_Path
    !Img_Case_Code = CompanyCaseType.Case_Code
    !Img_Case_Name = CompanyCaseType.Case_Name
    !Img_Page = CompanyCaseType.Img_Current_Page
    !Img_IsRegister = CompanyCaseType.Img_IsRegister
    !Img_Import_Date = CompanyCaseType.Img_ImportDate
    If CompanyCaseType.Img_IsRegister = False Then
        !Img_SSSQ = CompanyCaseType.Img_SSSQ
    End If
    .Update
    
End With

SaveImage = True
rstImage.Close

Exit Function

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
        SaveImage = False
    End If
End Function

Public Function ImageExisted(ByRef CompanyCaseType As CompanyCase) As Boolean
'****************************************************
'功能：检查某一企业的某种文书是否已经存在
'调用：frmImgScan，frmImgCopy
'返回值：True -- 存在；False -- 不存在
'****************************************************
On Error GoTo ErrorHandler

Dim FoundSQL As String

Dim rstImage As ADODB.Recordset

If CompanyCaseType.Img_IsRegister = False Then
    FoundSQL = "SELECT * FROM sys_Image " & _
            "WHERE QYBM='" & CompanyCaseType.QYBM & "' " & _
            "AND Img_Case_Code='" & CompanyCaseType.Case_Code & "' " & _
            "AND Img_Page=" & CompanyCaseType.Img_Current_Page & _
            "AND Img_SSSQ='" & CompanyCaseType.Img_SSSQ & "'"
Else
    FoundSQL = "SELECT * FROM sys_Image " & _
            "WHERE QYBM='" & CompanyCaseType.QYBM & "' " & _
            "AND Img_Case_Code='" & CompanyCaseType.Case_Code & "' " & _
            "AND Img_Page=" & CompanyCaseType.Img_Current_Page
End If

Set rstImage = New ADODB.Recordset
rstImage.Open FoundSQL, conCaseMain, 1, 1 ', adCmdText
With rstImage
    If Not .BOF Then .MoveFirst
    If .RecordCount > 0 Then
        CompanyCaseType.Img_SSSQ = !Img_SSSQ
        ImageExisted = True
    Else
        ImageExisted = False
    End If
End With

rstImage.Close

Exit Function
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
        ImageExisted = False
    End If
End Function


Public Function DeleteImage(CompanyCaseType As CompanyCase) As Boolean
'**********************************************************
'功能：将某张文书信息从数据库中删除，并将对应的图片文件删除
'调用：frmImgScan,frmImgCopy
'**********************************************************
On Error GoTo ErrorHandler

Dim strSELECT As String
Dim strWHERE As String

Dim rstImage As ADODB.Recordset

strSELECT = "SELECT Img_Path,Img_Name FROM sys_Image "

With CompanyCaseType
    If CompanyCaseType.Img_IsRegister = True Then
        strWHERE = "WHERE QYBM='" & .QYBM & "' " & _
                    "AND Img_Case_Code='" & .Case_Code & "' "
    Else
        strWHERE = "WHERE QYBM='" & .QYBM & "' " & _
                    "AND Img_Case_Code='" & .Case_Code & "' " & _
                    "AND Img_SSSQ='" & .Img_SSSQ & "' "
    End If
End With

Set rstImage = New ADODB.Recordset
rstImage.Open strSELECT & strWHERE, conCaseMain, 1, 1 ', adCmdText
With rstImage
    If Not .EOF Then .MoveLast
    If Not .BOF Then .MoveFirst
    
    '删除实际文件
    Do Until .EOF
        If Dir(!Img_Path & !Img_Name) <> vbNullString Then
            Kill (!Img_Path & !Img_Name)
        End If
        .MoveNext
    Loop
    
    '删除纪录
    If .RecordCount > 0 Then
        rstImage.Close
        conCaseMain.Execute "DELETE * FROM sys_Image " & strWHERE
        DeleteImage = True
    End If
End With

Exit Function

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
        DeleteImage = False
    End If
End Function

Public Sub RefreshCaption(lblCaption As Label, cmdNext As CommandButton, cmdPrevious As CommandButton, MoveForward As Boolean)
'*********************************************************
'功能: 刷新文书导入窗体的当前企业名称+文书名称+页码
'调用: frmImgScan 和 frmImgCopy 的 Form_Activate()
'*********************************************************

    On Error GoTo ErrorHandler
    
    Static nComp As Integer
    Static nCase As Integer
    Static nPage As Integer

    Dim strTemp As String
    Dim rstImage As ADODB.Recordset
    
    Set rstImage = New ADODB.Recordset
    
    '向前
    If MoveForward Then
        '页码 nPage+1
        nPage = nPage + 1
        'Right(CaseCodeName(nCase), 1) - 1是该种文书的起始页号
        If nPage > Right(CaseCodeName(nCase), 1) - 1 Then
            nCase = nCase + 1
            nPage = 0
            If nCase > UBound(CaseCodeName) Then
                nComp = nComp + 1
                nCase = 0
                If nComp > UBound(CompanyCodeName) Then
                    nComp = UBound(CompanyCodeName)
                End If
            End If
        End If
    End If
            
    '向后
    If Not MoveForward Then
        '页码 nPage-1
        nPage = nPage - 1
        '如果 nPage>0 则保持当前 nCase 和 nComp 不变
        '否则,nCase -1
        If nPage < 0 Then
            nCase = nCase - 1
            '如果 nCase 的值在上下限之间,则 nComp 不变
            '否则,nComp-1
            If nCase < LBound(CaseCodeName) Then
                nComp = nComp - 1
                '如果 nCase 的值在上下限之间,则 nCase 取最大值,nPage 取 CaseCodeName(nCase)
                '否则,nComp 取最小值,nCase 取最小值,nPage 取最小值 0
                If nComp < LBound(CompanyCodeName) Then
                    nComp = LBound(CompanyCodeName)
                    nCase = LBound(CaseCodeName)
                    nPage = 0
                Else
                    nCase = UBound(CaseCodeName)
                    nPage = Right(CaseCodeName(nCase), 1) - 1
                End If
            Else
                nPage = Right(CaseCodeName(nCase), 1) - 1
            End If
            
        End If
    End If
    
    '控制向前和向后按钮的可见性
    cmdNext.Enabled = True
    cmdPrevious.Enabled = True
    If nComp = UBound(CompanyCodeName) And nCase = UBound(CaseCodeName) And nPage = Int(Right(CaseCodeName(nCase), 1)) - 1 Then
        cmdNext.Enabled = False
    End If
    If nComp = LBound(CompanyCodeName) And nCase = LBound(CaseCodeName) And nPage = 0 Then
        cmdPrevious.Enabled = False
    End If
    
    '取得文书的页数
    rstImage.Open "SELECT * FROM sys_Case WHERE Case_Code='" & Left(CaseCodeName(nCase), CaseCodeLength) & "'", conCaseMain, 1, 1 ', adCmdText
    If Not rstImage.BOF Then rstImage.MoveFirst
    
    '显示当前企业+文书+页码
    strTemp = "企业名称: "
    strTemp = strTemp & Right(CompanyCodeName(nComp), Len(CompanyCodeName(nComp)) - QYBMLength - 1) & vbCrLf
    strTemp = strTemp & "企业编码: "
    strTemp = strTemp & Left(CompanyCodeName(nComp), QYBMLength) & vbCrLf & vbCrLf
    strTemp = strTemp & "文书类型: "
    strTemp = strTemp & Left(Right(CaseCodeName(nCase), Len(CaseCodeName(nCase)) - CaseCodeLength - 1), Len(Right(CaseCodeName(nCase), Len(CaseCodeName(nCase)) - CaseCodeLength - 1)) - 1) & vbCrLf & vbCrLf
    strTemp = strTemp & "页    数: 第 " & nPage + 1 & " 页 (共 " & rstImage!Case_Pages & " 页)"
    
    CompNum = nComp
    CaseNum = nCase
    PageNum = nPage
    
    lblCaption.Caption = strTemp
    
    rstImage.Close
    
Exit Sub
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
    End If
End Sub

Public Sub PutArrayToType()
'*************************************************************
'功能: 组合数组CompanyCodeName() 和数组 CaseCodeName()中的数据
'      形成类型数组CompanyCase()
'*************************************************************
On Error Resume Next

Dim nComp As Integer
Dim nCase As Integer

Dim DimCompany As Integer
Dim DimCase As Integer
Dim DimPage As Integer

Dim rstImage As ADODB.Recordset

DimCompany = UBound(CompanyCodeName)
DimCase = UBound(CaseCodeName)

ReDim CompanyCaseType(DimCompany, DimCase)

Set rstImage = New ADODB.Recordset

For nComp = 0 To DimCompany
    For nCase = 0 To DimCase
        
        If Left(CompanyCodeName(nComp), QYBMLength) <> vbNullString Then
            CompanyCaseType(nComp, nCase).QYBM = Left(CompanyCodeName(nComp), QYBMLength)
            CompanyCaseType(nComp, nCase).Nsrmc = Right(CompanyCodeName(nComp), Len(CompanyCodeName(nComp)) - (QYBMLength + 1))
        End If
        
        If Left(CaseCodeName(nCase), CaseCodeLength) <> vbNullString Then
            rstImage.Open "SELECT * FROM sys_Case WHERE Ope_Case_Code='" & Left(CaseCodeName(nCase), CaseCodeLength) & "'", conCaseMain, 1, 1 ', adCmdText
            If Not rstImage.BOF Then rstImage.MoveFirst
            CompanyCaseType(nComp, nCase).Case_Code = Left(CaseCodeName(nCase), CaseCodeLength)
            CompanyCaseType(nComp, nCase).Case_Name = Left(Right(CaseCodeName(nCase), Len(CaseCodeName(nCase)) - 5), Len(Right(CaseCodeName(nCase), Len(CaseCodeName(nCase)) - 5)) - 1)
            CompanyCaseType(nComp, nCase).Img_Current_Page = 1
            CompanyCaseType(nComp, nCase).Img_Page = rstImage!Case_Pages
            CompanyCaseType(nComp, nCase).Img_IsRegister = IIf(rstImage!IsRegister = 1, True, False)
            rstImage.Close
        End If
        
    Next nCase
Next nComp

End Sub