form_kejiv.frm

2008年版

        strSource = App.Path & "\excel\grid.xls"
        strDestination = App.Path & "\excel\temp.xls"
    End If
'    ElseIf A4 = "16K" Then
'        strSource = App.Path & "\excel2\grid.xls"
'        strDestination = App.Path & "\excel2\temp.xls"
'    End If
    
    FileCopy strSource, strDestination
    
    Set xlbook = xlapp.Workbooks.Open(strDestination)
    Set xlsheet = xlbook.Worksheets(1)
    If Text5.text = fondsCode Then
        xlsheet.Cells(1, 1) = fondsName
    Else
        xlsheet.Cells(1, 1) = fondsName2
    End If
    'xlsheet.Cells(2, 1) = Text4.text
    xlsheet.Cells(3, 1) = "        " & Text1.text
    xlsheet.Cells(4, 1) = "          " & Mid(Format(DTPicker2.Value, "yyyy-mm-dd"), 1, 4) & "      " & Mid(Format(DTPicker2.Value, "yyyy-mm-dd"), 6, 2) & "               " & Mid(Format(DTPicker3.Value, "yyyy-mm-dd"), 1, 4) & "      " & Mid(Format(DTPicker3.Value, "yyyy-mm-dd"), 6, 2)
    xlsheet.Cells(4, 3) = "      " & Combo2.text
    'xlsheet.Cells(5, 1) = "                      '" & Text8.text & "                     " & Text9.text
    xlsheet.Cells(5, 3) = "       " & Text3.text


    Set xlsheet = xlbook.Worksheets(2)
    'xlsheet.Cells(1, 1) = "卷内文件目录"
    lop = 3
        With ListView2.ListItems
    For numi = 1 To .Count
        xlsheet.Cells(lop, 1) = .Item(numi)
        For numj = 1 To ListView2.ColumnHeaders.Count - 1
        If numj <> 4 Then
            xlsheet.Cells(lop, numj + 1) = .Item(numi).SubItems(numj) '打印列
        End If
        If numj = 4 Then
            xlsheet.Cells(lop, 5) = .Item(numi).SubItems(numj - 1)  '责任者题名互换
        End If
        If numj = 5 Then
            xlsheet.Cells(lop, 4) = .Item(numi).SubItems(numj - 1)
        End If
        Next numj
        lop = lop + 1
    Next numi
    
    Dim isum, iprint As Integer
    isum = .Count
        iprint = isum Mod 15
        If iprint <> 0 Then
            iprint = 15 - iprint
            For numj = 1 To iprint
                    xlsheet.Cells(lop, 1) = "'"
                    lop = lop + 1
            Next numj
        End If
'打印空行
    End With
    
        Set xlsheet = xlbook.Worksheets(3)

        xlsheet.Cells(2, 3) = ""
        xlsheet.Cells(3, 3) = ""
        xlsheet.Cells(4, 3) = ""
        xlsheet.Cells(18, 3) = ""
        xlsheet.Cells(20, 3) = ""
        xlsheet.Cells(21, 3) = ""
        xlsheet.Cells(22, 3) = ""
        xlsheet.Cells(23, 3) = ""
        
        xlsheet.Cells(2, 4) = Text5.text + "-" + Text13.text + "-" + Text14.text + "-" + Text6.text + "-" + Text7.text + "-" + Text15.text
        xlsheet.Cells(3, 4) = Text3.text
        xlsheet.Cells(4, 4) = ""
        xlsheet.Cells(18, 4) = "'" + Text1.text
        xlsheet.Cells(20, 4) = "'" + Text12.text
        xlsheet.Cells(21, 4) = "'" + CStr(DTPicker1.Value)
        xlsheet.Cells(22, 4) = Combo2.text
        xlsheet.Cells(23, 4) = Combo1.text
    
    xlapp.Visible = True
    'xlsheet.PrintOut '执行打印
    xlbook.Save '保存文件
    'xlapp.quit '退出Excel
    
    Screen.MousePointer = vbDefault
    Exit Sub
e:
    MsgBox Err.Description
    Screen.MousePointer = vbDefault
    Set xlapp = Nothing
    Set xlbook = Nothing
    Set xlsheet = Nothing
End Sub

Private Sub DTPicker2_Change()
    DTPicker3.Value = Format(DTPicker2.Value, "yyyy-mm-dd")
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()
    Select Case form_AnJuan.List1.ListIndex
    Case 2, 3
    
    Case 4
        Label18.Caption = "门类号"
        Label19.Caption = "分类号"
        Label20.Caption = "项目(课题)代号"
        Label21.Caption = "保管单位号"
        Label22.Visible = False
        Text15.Visible = False
    Case 5
        Label19.Visible = False
        Text14.Visible = False
        Label20.Caption = "分类号"
        Label21.Caption = "目录号"
        Label22.Caption = "保管单位号"
        Text15.Left = Text15.Left + 100
    End Select
    BackColor = bgColor
    Label1.Caption = form_AnJuan.List1.text + "目录信息"
    Label1.BackColor = bgColor
    
    Combo1.AddItem "公开"
    Combo1.AddItem "限制"
    Combo1.AddItem "秘密"
    Combo1.AddItem "机密"
    Combo1.ListIndex = 2
    
    Combo2.AddItem "永久"
    Combo2.AddItem "长期"
    Combo2.AddItem "短期"
    Combo2.ListIndex = 0
    
    Combo3.AddItem "页"
    Combo3.AddItem "张"
    Combo3.AddItem "件"
    Combo3.ListIndex = 0
    
    Combo4.AddItem "纸质"
    Combo4.AddItem "光盘"
    Combo4.AddItem "其它"
    Combo4.ListIndex = 0
    If form_AnJuan.List1.ListIndex = 2 Then
        Combo4.Clear
        Combo4.AddItem "纸质"
        Combo4.AddItem "光盘"
        Combo4.AddItem "声像"
        Combo4.AddItem "其它"
    End If
    
    Text1.text = ""
    Text2.text = ""
    Text3.text = ""
    Text4.text = ""
    Text5.text = fondsCode
    Text6.text = ""
    Text7.text = ""
    Text8.text = ""
    Text9.text = ""
    Text10.text = 0
    Text11.text = ""
    Text12.text = ""
    
    Text14.text = 0
    Text15.text = ""
    '类别号
    Select Case form_AnJuan.List1.ListIndex
        Case 2
            Text13.text = "JJ"
        Case 3
            Text13.text = "SB"
        Case 4
            Text13.text = "KY"
        Case 5
            Text13.text = "CP"
    End Select
    DTPicker1.Value = Date
    DTPicker2.Value = Date
    DTPicker3.Value = Date
    
    Text1.MaxLength = 1000
    Text2.MaxLength = 100
    Text3.MaxLength = 24
    Text4.MaxLength = 20
    Text5.MaxLength = 4
    Text6.MaxLength = 10
    Text7.MaxLength = 5
    Text8.MaxLength = 20
    Text9.MaxLength = 4
    Text10.MaxLength = 4
    Text11.MaxLength = 1000
    Text12.MaxLength = 255
    Text13.MaxLength = 4
    Text14.MaxLength = 5
    Text15.MaxLength = 6
    
    If flag = "Insert" Then
        Height = Height - 1900
    End If
    If flag = "Modify" Then
        rs.Open "select * from T_ARCHIVE_0300_VOLUME where RECORD_SEQUENCE_NUMBER=" & num & "", conn
            If rs!TITLE_PROPER <> "" Then
            Text1.text = rs!TITLE_PROPER
            End If
            If rs!DISCRIPTOR <> "" Then
            Text2.text = rs!DISCRIPTOR
            End If
            If rs!REFERENCE_CODE_OF_FILE_OFFICE <> "" Then
            Text3.text = rs!REFERENCE_CODE_OF_FILE_OFFICE
            End If
            If rs!describing_date <> "" Then
            DTPicker1.Value = rs!describing_date
            End If
            If rs!MEDIUM_type <> "" Then
            Text4.text = rs!MEDIUM_type
            End If
            If rs!PERSON_FOR_DESCRIPTION <> "" Then
            Text8.text = rs!PERSON_FOR_DESCRIPTION
            End If
            If rs!fonds_code <> "" Then
            Text5.text = rs!fonds_code
            End If
            If rs!series_CODE <> "" Then
            Text6.text = rs!series_CODE
            End If
            If rs!FILE_NUMBER <> "" Then
            Text7.text = rs!FILE_NUMBER
            End If
            If rs!ARCHIVE_YEAR <> "" Then
            Text9.text = rs!ARCHIVE_YEAR
            End If
            If rs!DATE_BEGUN <> "" Then
            DTPicker2.Value = rs!DATE_BEGUN
            End If
            If rs!DATE_FINISHED <> "" Then
            DTPicker3.Value = rs!DATE_FINISHED
            End If
            If rs!SECRET_LEVEL_FOR_DOCUMENTS <> "" Then
            Combo1.ListIndex = rs!SECRET_LEVEL_FOR_DOCUMENTS
            End If
            If rs!RETENTION_PERIOD <> "" Then
            Combo2.ListIndex = rs!RETENTION_PERIOD
            End If
            If rs!medium_quantity <> "" Then
            Text10.text = rs!medium_quantity
            End If
            If rs!MEDIUM_UNIT <> "" Then
            Combo3.text = rs!MEDIUM_UNIT
            End If
            If rs!NOTES_OF_ARCHIVIST <> "" Then
            Text11.text = rs!NOTES_OF_ARCHIVIST
            End If
            If rs!authorized_unit <> "" Then
            Text12.text = rs!authorized_unit
            End If
            Text13.text = xml("ITEM_CODE")
            Text14.text = xml("STAGE_CODE")
            Text15.text = xml("SERIAL_NUMBER")
            Combo4.text = Text4.text
            If xml("IS_SHARING") <> "" Then
                Check1.Value = xml("IS_SHARING")
            End If
        rs.Close
    strSql = "select count(*) from T_ARCHIVE_0300_FILE where FONDS_CODE='" & Text5.text & "' and ITEM_CODE='" & Text13.text & "' and STAGE_CODE='" & Text14.text & "' and SERIES_CODE='" & Text6.text & "' and FILE_NUMBER='" & Text7.text & "' and SERIAL_NUMBER='" & Text15.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text3.text & "'"
        'MsgBox strSql
        rs.Open strSql, conn
            Dim sum As Integer
            sum = rs.Fields(0).Value
        rs.Close
            If sum = 0 Then
                Height = Height - 1900
                'MsgBox sum
            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_0300_file where flag =1 and FONDS_CODE='" & Text5.text & "' and ITEM_CODE='" & Text13.text & "' and STAGE_CODE='" & Text14.text & "' and SERIES_CODE='" & Text6.text & "' and FILE_NUMBER='" & Text7.text & "' and SERIAL_NUMBER='" & Text15.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text3.text & "' order by number_of_page"
                Text10.Visible = False
                rs.Open strSql, conn
                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")
                        Text10.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
            '添加记录到列表框
            Text10.Visible = True
            rs.Open "update T_ARCHIVE_0300_VOLUME set MEDIUM_QUANTITY=" & Text10.text & "   where RECORD_SEQUENCE_NUMBER=" & num & ""
            End If
    End If
    strfile = Text3.text
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 Text9_KeyPress(KeyAscii As Integer)
    If Not (KeyAscii > 47 And KeyAscii < 59) And KeyAscii <> 8 Then
        KeyAscii = 0
        MsgBox "请输入数字!", 48, ""
    End If
End Sub