form_accountv.frm

2008年版

    MsgBox Err.Description
    Screen.MousePointer = vbDefault
    Set xlapp = Nothing
    Set xlbook = Nothing
    Set xlsheet = Nothing
End Sub

Private Sub Command1_KeyPress(KeyAscii As Integer)
    KeyAscii = 0
End Sub

Private Sub Command2_Click()
On Error GoTo e:
        If DTPicker2.Value < DTPicker1.Value Then MsgBox "终止时间必须大于起始时间！", 48, "": Exit Sub
        Text13.text = Replace(Text13.text, "-", "~")
        If fand("T_ARCHIVE_0203_volume", Text1.text) > 0 Then
            If flag = "Insert" Then
                MsgBox "室编档号重复,请核查!", vbExclamation, ""
                Exit Sub
            ElseIf Not (strfile = Text1.text) Then
                    MsgBox "室编档号重复,请核查!", vbExclamation, ""
                    Exit Sub
            End If
        End If
        If Text1.text = "" Or Text1.text = " " Then
            MsgBox "请输入室编档号！", vbExclamation, ""
            Exit Sub
        End If
        If Text9.text = "" Or Text9.text = " " Then
            MsgBox "请输入卷（册袋）标题！", vbExclamation, ""
            Exit Sub
        End If

        If Len(Text11.text) <> 4 Then
            MsgBox "归档年份请输入4位!", 48, ""
            Exit Sub
        End If
        '归档年分位数判断
        If Me.DTPicker2.Value < Me.DTPicker1.Value Then
            MsgBox "终止时间不应小于起始时间！", 48, ""
            Exit Sub
        End If
    If flag = "Insert" Then
        flagWhere = ""
        Dim sum As Integer
        If Text2.text <> "" And Text3.text <> "" And Text4.text <> "" And Text5.text <> "" Then
        strSql = "select count(*) from T_ARCHIVE_0203_volume where FONDS_CODE='" & Text2.text & "' and CATALOG_CODE='" & Text4.text & "' and FILE_NUMBER='" & Text5.text & "'  and series_code='" & Text3.text & "' "
        rs.Open strSql, conn
            sum = rs.Fields(0).Value
            Debug.Print sum
        rs.Close
        If sum > 0 Then
            MsgBox "档号重复,请核查!", vbExclamation, ""
            Exit Sub
        End If
        End If '档号重复判断
        
        num = id("T_ARCHIVE_0203_VOLUME")
        strSql = "insert into T_ARCHIVE_0203_VOLUME "
        strSql = strSql + "(RECORD_SEQUENCE_NUMBER,FONDS_CODE,SERIES_CODE,FILE_NUMBER,CATALOG_CODE"
        strSql = strSql + ",CLASS_CODE,ITEM_CODE,SERIAL_NUMBER,TITLE_PROPER"
        strSql = strSql + ",RETENTION_PERIOD,DATE_BEGUN,DATE_FINISHED,MEDIUM_QUANTITY"
        strSql = strSql + ",REFERENCE_CODE_OF_FILE_OFFICE,ACCOUNT_BOOK_TYPE,VOUCHER_CODE,PERSON_FOR_DESCRIPTION"
        strSql = strSql + ",DESCRIBING_DATE,NOTES_OF_ARCHIVIST,ARCHIVE_YEAR,flag"
        strSql = strSql + ",sort_code,IS_SHARING"
        strSql = strSql + ")values("
        strSql = strSql + "" & num & ",'" & Text2.text & "','" & Text3.text & "','" & Text5.text & "','" & Text4.text & "'"
        strSql = strSql + ",'" & Combo1.text & "','" & Text12.text & "'," & Text10.text & ",'" & Text9.text & "','" & Combo2.text & "'"
        strSql = strSql + ",'" & Format(DTPicker1.Value, "yyyy-mm-dd") & "','" & Format(DTPicker2.Value, "yyyy-mm-dd") & "'," & Text8.text & ",'" & Text1.text & "','" & Combo1.text & "'"
        strSql = strSql + ",'" & Text13.text & "','" & Text14.text & "','" & Format(DTPicker3.Value, "yyyy-mm-dd") & "','" & Text15.text & "','" & Text11.text & "',0"
        strSql = strSql + ",'" & Text6.text & "','" & Check1.Value & "'"
        strSql = strSql + ")"
    ElseIf flag = "Modify" Then
        strSql = "update T_ARCHIVE_0203_VOLUME set "
        strSql = strSql + " FONDS_CODE                   ='" & Text2.text & "' ,SERIES_CODE                  ='" & Text3.text & "',FILE_NUMBER                  ='" & Text5.text & "'  ,CATALOG_CODE                 ='" & Text4.text & "'"
        strSql = strSql + ",CLASS_CODE                   ='" & Combo1.text & "',ITEM_CODE                    ='" & Text12.text & "',SERIAL_NUMBER                =" & Text10.text & ",TITLE_PROPER                 ='" & Text9.text & "'"
        strSql = strSql + ",RETENTION_PERIOD             ='" & Combo2.text & "',DATE_BEGUN                   ='" & Format(DTPicker1.Value, "yyyy-mm-dd") & "',DATE_FINISHED                ='" & Format(DTPicker2.Value, "yyyy-mm-dd") & "',MEDIUM_QUANTITY              =" & Text8.text & ",REFERENCE_CODE_OF_FILE_OFFICE='" & Text1.text & "',ACCOUNT_BOOK_TYPE            ='" & Combo1.text & "',VOUCHER_CODE                 ='" & Text13.text & "'"
        strSql = strSql + ",PERSON_FOR_DESCRIPTION       ='" & Text14.text & "',DESCRIBING_DATE              ='" & Format(DTPicker3.Value, "yyyy-mm-dd") & "',NOTES_OF_ARCHIVIST           ='" & Text15.text & "',ARCHIVE_YEAR                 ='" & Text11.text & "'"
        strSql = strSql + ",sort_code='" & Text6.text & "',IS_SHARING='" & Check1.Value & "'"
        strSql = strSql + " where RECORD_SEQUENCE_NUMBER=" & num & ""
        For listI = 1 To ListView2.ListItems.Count
                listSql = "update T_ARCHIVE_0203_FILE set REFERENCE_CODE_OF_FILE_OFFICE='" & Text1.text & "',FONDS_CODE='" & Text2.text & "' and CATALOG_CODE='" & Text4.text & "' and FILE_NUMBER='" & Text5.text & "'  and series_code='" & Text3.text & "'   where RECORD_SEQUENCE_NUMBER=" & ListView2.ListItems(listI).SubItems(1) & ""
                 rs.Open listSql, conn
            Next listI
    End If
        'MsgBox strSql
        rs.Open strSql, conn
        MsgBox "保存成功!", vbInformation, ""
    If flag = "Insert" Then
        Dim itmX As ListItem
        Set itmX = form_AnJuan.ListView1.ListItems.Add(, , form_AnJuan.ListView1.ListItems.Count + 1)
        itmX.SubItems(1) = num
        itmX.SubItems(2) = Text1.text
        itmX.SubItems(3) = Text9.text
        itmX.SubItems(4) = Format(DTPicker1.Value, "yyyy-mm-dd") + " " + Format(DTPicker2.Value, "yyyy-mm-dd")
        itmX.SubItems(5) = Text8.text
    End If
    'If flag = "Modify" Then
        form_AnJuan.Refresh
    'End If
    Exit Sub
e:
    'MsgBox Err.Number & Err.Description, vbExclamation, ""
    MsgBox "请输入正确数据格式", vbExclamation, ""
    If rs.State = 1 Then
        rs.Close
    End If
End Sub

Private Sub Command3_Click()
    Unload Me
End Sub

Private Sub Command4_Click()
Dim i As Integer
If MsgBox("确实要移除吗？", vbYesNo + vbQuestion, "") = vbYes Then
    rs.Open "update T_ARCHIVE_0203_FILE set flag=0,FONDS_CODE='',CATALOG_CODE='',FILE_NUMBER='',series_code='' where RECORD_SEQUENCE_NUMBER=" & ListView2.SelectedItem.SubItems(1) & ""
    MsgBox "移除成功!", vbExclamation, ""
    
    Dim itmX As ListItem
        Set itmX = form_AnJuan.ListView2.ListItems.Add(, , form_AnJuan.ListView1.ListItems.Count + 1)
        For i = 1 To 5
            itmX.SubItems(i) = ListView2.SelectedItem.SubItems(i)
        Next i
    ListView2.ListItems.Remove (ListView2.SelectedItem.Index)
End If
form_AnJuan.Refresh
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
    SendKeys "{tab}"
    KeyAscii = 0
    End If
End Sub
Private Sub Form_Load()
    Label1.Caption = form_AnJuan.Label4.Caption + "目录信息"
    Label1.BackColor = bgColor
    
    Combo2.AddItem "3年"
    Combo2.AddItem "5年"
    Combo2.AddItem "10年"
    Combo2.AddItem "15年"
    Combo2.AddItem "25年"
    Combo2.AddItem "永久"
    Combo2.ListIndex = 0
    '类别定义
    Combo1.AddItem ""
    Combo1.AddItem "报表"
    Combo1.AddItem "帐册"
    Combo1.AddItem "凭证"
    Combo1.AddItem "其它"
    Combo1.ListIndex = 1
    
    Text1.text = ""
    Text2.text = fondsCode
    Text3.text = ""
    Text4.text = 0
    Text5.text = 0
    Text6.text = "KJ"
    Text6.Enabled = False
    Text8.text = 0
    Text9.text = ""
    Text10.text = 0
    Text11.text = ""
    Text12.text = ""
    Text13.text = ""
    Text14.text = ""
    Text15.text = ""
    DTPicker1.Value = Date
    DTPicker2.Value = Date
    DTPicker3.Value = Date
    
    Text1.MaxLength = 24
    Text2.MaxLength = 3 '
    Text3.MaxLength = 15
    Text4.MaxLength = 2 '
    Text5.MaxLength = 4 '
    Text8.MaxLength = 4
    Text9.MaxLength = 1000
    Text10.MaxLength = 5
    Text11.MaxLength = 4
    Text12.MaxLength = 6
    Text13.MaxLength = 10
    Text14.MaxLength = 20
    Text15.MaxLength = 1000
    
    If flag = "Insert" Then
        Height = Height - 1900
    End If
    If flag = "Modify" Then
        rs.Open "select * from T_ARCHIVE_0203_VOLUME where RECORD_SEQUENCE_NUMBER=" & num & "", conn
            Text2.text = xml("FONDS_CODE")
            Text3.text = xml("SERIES_CODE")
            Text5.text = xml("FILE_NUMBER")
            Text4.text = xml("CATALOG_CODE")
            Combo1.text = xml("CLASS_CODE")
            Text12.text = xml("ITEM_CODE")
            Text10.text = xml("SERIAL_NUMBER")
            Text9.text = xml("TITLE_PROPER")
            Combo2.text = xml("RETENTION_PERIOD")
            DTPicker1.Value = xml("DATE_BEGUN")
            DTPicker2.Value = xml("DATE_FINISHED")
            Text8.text = xml("MEDIUM_QUANTITY")
            Text1.text = xml("REFERENCE_CODE_OF_FILE_OFFICE")
            strfile = Text1.text
            Combo1.text = xml("ACCOUNT_BOOK_TYPE")
            Text13.text = xml("VOUCHER_CODE")
            Text14.text = xml("PERSON_FOR_DESCRIPTION")
            If xml("DESCRIBING_DATE") <> "" Then
                DTPicker3.Value = xml("DESCRIBING_DATE")
            End If
            Text15.text = xml("NOTES_OF_ARCHIVIST")
            Text11.text = xml("ARCHIVE_YEAR")
            If xml("IS_SHARING") <> "" Then
                Check1.Value = xml("IS_SHARING")
            End If
        rs.Close
        strSql = "select count(*) from T_ARCHIVE_0203_FILE where FONDS_CODE='" & Text2.text & "' and CATALOG_CODE='" & Text4.text & "' and FILE_NUMBER='" & Text5.text & "'  and series_code='" & Text3.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text1.text & "'"
        'MsgBox strSql
        rs.Open strSql, conn
            Dim sum As Integer
            sum = rs.Fields(0).Value
'MsgBox rs.Fields(0).Value
        rs.Close
            If sum = 0 Then
                Height = Height - 1900
                
            Else
        With ListView2
                .ColumnHeaders.Clear
                .ColumnHeaders.Add , , "序号", 600
                .ColumnHeaders.Add , , "唯一号", 0
                .ColumnHeaders.Add , , "文件编号", 1200
                .ColumnHeaders.Add , , "文 件 材 料 题 名", 3500
                .ColumnHeaders.Add , , "责任者", 1500
                .ColumnHeaders.Add , , "日期", 1500
                .ColumnHeaders.Add , , "页号", 1200
                .ColumnHeaders.Add , , "备注", 1200
                .View = lvwReport
                End With
                ListView2.ListItems.Clear
                Dim i, j As Integer
                i = 0
                j = 0
                strSql = "select * from t_archive_0203_file where flag =1 and FONDS_CODE='" & Text2.text & "' and CATALOG_CODE='" & Text4.text & "' and FILE_NUMBER='" & Text5.text & "'  and series_code='" & Text3.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text1.text & "' order by number_of_page"
                rs.Open strSql, conn
                'MsgBox strSql
                While Not rs.EOF
                j = j + 1
                    Set itmX = ListView2.ListItems.Add(, , j)
                        itmX.SubItems(1) = rs.Fields(0).Value
                        itmX.SubItems(2) = xml("document_code")
                        itmX.SubItems(3) = xml("TITLE_PROPER")
                        itmX.SubItems(4) = xml("PRIMARY_CREATOR")
                        itmX.SubItems(5) = xml("date_begun")
                        itmX.SubItems(6) = Format(CStr(i + 1), "000") + " - " + Format(CStr(i + CLng(xml("item_number"))), "000")
                        Text8.text = Format(CStr(i + CLng(xml("item_number"))), "000")
                        itmX.SubItems(7) = xml("NOTES_OF_ARCHIVIST")
                    i = i + CLng(xml("item_number"))
                    rs.MoveNext
                Wend
                rs.Close
            '添加记录到列表框
            rs.Open "update T_ARCHIVE_0203_VOLUME set MEDIUM_QUANTITY=" & Text8.text & " where RECORD_SEQUENCE_NUMBER=" & num & "", conn
            End If
    End If
    strfile = Text1.text
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
form_AnJuan.Refresh
End Sub
Private Sub ListView2_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Dim i As Integer
    With ListView2
        For i = 1 To .ColumnHeaders.Count
            If i = ColumnHeader.Index Then
                .SortKey = i - 1            ''对指定的列进行排列
                .Sorted = True
                        If .SortOrder = lvwDescending Then
                            .SortOrder = lvwAscending
                        Else
                            .SortOrder = lvwDescending
                        End If
                .Refresh
            End If
        Next
    End With
End Sub

Private Sub Text11_KeyPress(KeyAscii As Integer)
    If Not (KeyAscii > 47 And KeyAscii < 59) And KeyAscii <> 8 Then
        KeyAscii = 0
        MsgBox "请输入数字!", 48, ""
    End If
End Sub

Private Sub Text8_KeyPress(KeyAscii As Integer)
    If Not (KeyAscii > 47 And KeyAscii < 59) And KeyAscii <> 8 Then
        KeyAscii = 0
        MsgBox "请输入数字!", 48, ""
    End If
End Sub