module1_public.bas

2008年版

Attribute VB_Name = "Module1_public"
Public conn As New ADODB.Connection
Public rs As New Recordset
Public colname As String
Public strSql As String
Public listSql As String
Public listI As Integer
Public num As Long      '计数器
Public flag As String   '添加修改标志
Public query As String '文件级查寻案卷和文件级卷区别标志
Public allSelect As Boolean  '全选标志
Public fondsCode As String '全宗号
Public fondsName As String '全宗名称
Public itmX As ListItem '列表项
Public flagDate As String '日期选择控件判断 1为点中
Public queryflag As String '查询刷新列表
Public fondsName2 As String '全宗名称修改
Public A4 As String 'A4打印设置
Public flagWhere As String '查询打印的条件（案卷）
Public flagWhereF As String '查询条件（文件级）

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

Public Function strConn() As String
    If Right(App.Path, 1) = "\" Then
        strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "db\db.mdb;Persist Security Info=False"
    Else
        strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + App.Path + "\db\db.mdb;Persist Security Info=False"
    End If
    
End Function
Public Function xml(colname) As String
On Error Resume Next
    If rs.Fields(colname) <> "" And IsNull(colname) = False Then
        If rs(colname).Type = adDate And rs(colname) <> "" Then
            xml = Format(rs(colname), "yyyy-mm-dd")
        Else
            xml = rs.Fields(colname)
        End If
        xml = Replace(xml, "<", "&lt;")
        xml = Replace(xml, ">", "&gt;")
        Else
        xml = ""
    End If
End Function
Public Function id(table As String) As Long
On Error Resume Next
    strSql = "select count(*) from " + table
        rs.Open strSql, conn
        num = rs.Fields(0).Value
        rs.Close
        If num = 0 Then
            num = 1000001
        Else
            strSql = "select max(RECORD_SEQUENCE_NUMBER) from " + table
            rs.Open strSql, conn
            num = rs.Fields(0).Value
            rs.Close
            num = num + 1 '流水号判断
            If num < 1000001 Then
                num = 1000001
            End If
       End If
       id = num
End Function
Public Function fand(table As String, colname) As Long '室编档号唯一性校验
    On Error Resume Next
    fand = 0
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where REFERENCE_CODE_OF_FILE_OFFICE='" + colname + "'"
    Debug.Print strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fand = sum
End Function
Public Function fond(table As String, colname, colName1) As Long '室编档号唯一性校验
    On Error Resume Next
    fond = 0
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where REFERENCE_CODE_OF_FILE_OFFICE='" + colname + "'" + "  and number_of_page=" + colName1
       Debug.Print strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fond = sum
End Function
Public Function fondMedia(table As String, colname As String, colName1 As String, colName2 As Integer) As Long  '室编档号唯一性校验
    On Error Resume Next
    fondMedia = 0
    'MsgBox "inFondMedia function"
    'MsgBox table + "/" + colName + "/" + colName1 + "/" & colName2
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where REFERENCE_CODE_OF_FILE_OFFICE='" + colname + "'" + "  and REFERENCED_CODE='" + colName1 + "' and class_code='" & colName2 & "'"
       Debug.Print "fondMedia---" + strSql
       'MsgBox "fondMedia---" + strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fondMedia = sum
End Function
Public Function fondnumberOFpage(table As String, colname) As Long '室编档号唯一性校验
    On Error Resume Next
    fondnumberOFpage = 0
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where number_of_page='" + colname + "'"
       ' MsgBox strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fondnumberOFpage = sum
End Function
Public Function fand2(table As String, colname) As Long '科技档案室编档号唯一性校验
   On Error Resume Next
    fand2 = 0
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where REFERENCE_CODE_OF_FILE_OFFICE='" + colname + "' and class_code='" & form_AnJuan.List1.ListIndex & "'"
    Debug.Print strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fand2 = sum
End Function
Public Function fandss(table As String, colname, col As String) As Long '照片档案室编档号唯一性校验
   On Error Resume Next
    fandss = 0
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where REFERENCE_CODE_OF_FILE_OFFICE='" + colname + "' and STARTING_PHOTO_CODE='" & col & "'"
    Debug.Print strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fandss = sum
End Function
Public Function fandsss(table As String, colname, col As String) As Long '媒体档案室编档号唯一性校验
    On Error Resume Next
    fandsss = 0
    Dim sum As Integer
    strSql = "select count(*) from " + table + " where REFERENCE_CODE_OF_FILE_OFFICE='" + colname + "' and REFERENCED_CODE='" & col & "'"
    Debug.Print strSql
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        fandsss = sum
End Function

Public Function returnInputState(archiveTitle As String, archiveNum As String, itemTitle As String, itemNum As String) As String
    Dim rtString As String
    rtString = archiveTitle & "：" & archiveNum & vbCrLf & itemTitle & "：" & itemNum & vbCrLf & "保存成功！"
    returnInputState = rtString
End Function

Public Function updateReferenceCode(rs As Recordset, startNo As Long, colname As String) As Recordset
On Error GoTo e
    Dim recNum As Long
    
    recNum = startNo
    If Not rs.BOF And rs.EOF Then
        rs.MoveFirst
    End If
    
    While Not rs.EOF
        rs(colname).Value = makeReferenceCode(CStr(recNum), 4)
        recNum = recNum + 1
        rs.MoveNext
    Wend
    rs.UpdateBatch
    Set updateReferenceCode = rs
    Exit Function
e:
    Err.Raise Err.Number, , Err.Description
End Function

Public Function makeReferenceCode(ByVal refString As String, ByVal strLength As Integer) As String
    Dim rtString As String
    Dim zeroString As String
    Dim i As Integer
    rtString = refString
    zeroString = ""
    
    For i = Len(refString) To strLength - 1
        zeroString = zeroString & "0"
    Next i
    rtString = zeroString & rtString
    makeReferenceCode = rtString
End Function

Public Function sortRecord(Optional ByVal tableName As String = "t_archive_file_volume_temp", _
                            Optional ByVal targetTable As String = "t_archive_file_volume_temp", _
                            Optional ByVal refStartNo As Long = 0, _
                            Optional officeStartNo As Long = 0, _
                            Optional isLock As Long = 0) As Recordset
On Error GoTo e
    Dim rsYear As New Recordset
    Dim rsKeepPeriod As New Recordset
    Dim rsOffice As New Recordset
    Dim rsCode As New Recordset
    Dim rsTemp As New Recordset
    Dim refStartNoTemp As Long
    Dim officeStartNoTemp As Long
    
    refStartNoTemp = 0
    officeStartNoTemp = 0
    
    rsYear.Open "select distinct(archive_year) from " & tableName, conn
    While Not rsYear.EOF
        rsKeepPeriod.Open "select distinct(RETENTION_PERIOD) from " & tableName & " where archive_year='" & rsYear(0) & "'", conn
        While Not rsKeepPeriod.EOF
            rsOffice.Open "select distinct(office_code) from " & tableName & " where archive_year='" & rsYear(0) & "' and RETENTION_PERIOD='" & rsKeepPeriod(0) & "'", conn
            While Not rsOffice.EOF
                If refStartNo = 0 Then
                    rsTemp.Open "select max(reference_code_of_file_office) from " & targetTable & " where archive_year='" & rsYear(0) & "' and RETENTION_PERIOD='" & rsKeepPeriod(0) & "' and locked=1", conn
                    refStartNoTemp = 1
                    If Not IsNull(rsTemp(0)) Then
                        refStartNoTemp = Val(rsTemp(0)) + 1
                    End If
                    rsTemp.Close
                ElseIf refStartNo > 0 Then
                    refStartNoTemp = refStartNo
                End If
                If refStartNoTemp > 0 Then
                    rsCode.Open "select * from " & tableName & " where archive_year='" & rsYear(0) & "' and RETENTION_PERIOD='" & rsKeepPeriod(0) & "' and locked=" & isLock & " order by archive_year,RETENTION_PERIOD,office_code,office_reference_code", conn, adOpenDynamic, adLockOptimistic
                    Call updateReferenceCode(rsCode, refStartNoTemp, "reference_code_of_file_office")
                    Call updateReferenceCode(rsCode, refStartNoTemp, "boxCode")
                    rsCode.Close
                End If
                
                If officeStartNo = 0 Then
                    rsTemp.Open "select max(office_reference_code) from " & targetTable & " where archive_year='" & rsYear(0) & "' and RETENTION_PERIOD='" & rsKeepPeriod(0) & "' and office_code='" & rsOffice(0) & "' and locked=1", conn
                    officeStartNoTemp = 1
                    If Not IsNull(rsTemp(0)) Then
                        officeStartNoTemp = rsTemp(0) + 1
                    End If
                    rsTemp.Close
                ElseIf officeStartNo > 0 Then
                    officeStartNoTemp = officeStartNo
                End If
                If officeStartNoTemp > 0 Then
                    rsCode.Open "select * from " & tableName & " where archive_year='" & rsYear(0) & "' and RETENTION_PERIOD='" & rsKeepPeriod(0) & "' and office_code='" & rsOffice(0) & "' and locked=" & isLock & " order by archive_year,RETENTION_PERIOD,office_code,office_reference_code", conn, adOpenDynamic, adLockOptimistic
                    Call updateReferenceCode(rsCode, officeStartNoTemp, "office_reference_code")
                    rsCode.Close
                End If
                
                refStartNoTemp = 0
                officeStartNoTemp = 0
                
                rsOffice.MoveNext
            Wend
            rsOffice.Close
            rsKeepPeriod.MoveNext
        Wend
        rsKeepPeriod.Close
        rsYear.MoveNext
    Wend
    rsYear.Close
    Exit Function
e:
    Err.Raise Err.Number, "sort record", Err.Description
End Function

Public Sub closeRecordSet(rs As Recordset)
On Error GoTo e
    If rs.State = ADODB.adStateOpen Then
        rs.Close
    End If
    Exit Sub
e:
    Err.Raise Err.Number, "Close RecordSet", Err.Description
End Sub

Public Function getNextRefCode(ByVal year As String, ByVal keepPeriod As String, ByVal officeCode As String) As String
On Error GoTo e
    Dim rtString As String
    Dim rsCode As New Recordset
    
    strSql = "select max(reference_code_of_file_office) from t_archive_file_volume where archive_year='" & year & "' and RETENTION_PERIOD='" & keepPeriod & "'"
    rsCode.Open strSql, conn
    If Not IsNull(rsCode(0)) Then
        rtString = makeReferenceCode(Val(rsCode(0)) + 1, 4)
    Else
        rtString = makeReferenceCode("1", 4)
    End If
    rsCode.Close
    getNextRefCode = rtString
    Exit Function
e:
    Err.Raise Err.Number, "getNextReferenceCode", Err.Description
End Function

Public Function getNextOfficeRefCode(ByVal year As String, ByVal keepPeriod As String, ByVal officeCode As String) As String
On Error GoTo e
    Dim rtString As String
    Dim rsCode As New Recordset
    
    strSql = "select max(office_reference_code) from t_archive_file_volume where archive_year='" & year & "' and RETENTION_PERIOD='" & keepPeriod & "' and office_code='" & officeCode & "'"
    rsCode.Open strSql, conn
    If Not IsNull(rsCode(0)) Then
        rtString = makeReferenceCode(Val(rsCode(0)) + 1, 4)
    Else
        rtString = makeReferenceCode("1", 4)
    End If
    rsCode.Close
    getNextOfficeRefCode = rtString
    Exit Function
e:
    Err.Raise Err.Number, "getNextOfficeReferenceCode", Err.Description
End Function
Public Function updateSequence(rs As Recordset, startNo As Long, colname As String) As Recordset
On Error GoTo e
    Dim recNum As Long
    
    recNum = startNo
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
    End If
    
    While Not rs.EOF
        rs(colname).Value = recNum
        recNum = recNum + 1
        rs.MoveNext
    Wend
    rs.UpdateBatch
    Set updateSequence = rs
    Exit Function
e:
    Err.Raise Err.Number, , Err.Description
End Function