form_zhuanyev.frm

2008年版

    Dim numi, numj As Integer
    'Dim xlbook As Excel.Workbook
    'Dim xlsheet As Excel.Worksheet
    
    Screen.MousePointer = vbHourglass
    
    Set xlapp = CreateObject("Excel.Application")
    xlapp.Visible = False
'    If A4 = "A4" Then
    If Right(App.Path, 1) = "\" Then
        strSource = App.Path & "excel\grid.xls"
        strDestination = App.Path & "excel\temp.xls"
    Else
        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) = "                      " & Text14.text & "                     " & Text10.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
    
    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 = DTPicker2.Value
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()
    BackColor = bgColor
    Label1.Caption = form_AnJuan.List1.text + "目录信息"
    Label1.BackColor = bgColor
    
    Combo1.AddItem "公开"
    Combo1.AddItem "限制"
    Combo1.AddItem "秘密"
    Combo1.AddItem "机密"
    Combo1.ListIndex = 1
    
    Combo2.AddItem "永久"
    Combo2.AddItem "长期"
    Combo2.AddItem "短期"
    Combo2.ListIndex = 0
    
    Combo3.AddItem "页"
    Combo3.AddItem "张"
    Combo3.AddItem "件"
    Combo3.ListIndex = 0
    
    Text1.text = ""
    Text2.text = ""
    Text3.text = ""
    Text4.text = ""
    Text5.text = fondsCode
    Text5.Enabled = False
    Text6.text = ""
    Text7.text = ""
    Text8.text = ""
    Text9.text = ""
    Text10.text = 0
    Text11.text = ""
    Text13.text = ""
    Text14.text = 0
    DTPicker1.Value = Date
    DTPicker2.Value = Date
    DTPicker3.Value = Date
    
    Combo4.AddItem "KJD"
    Combo4.AddItem "KJZ"
    Combo4.ListIndex = 0
    Combo4.Visible = False
    Select Case form_AnJuan.List1.ListIndex
    Case 15
        Text12.text = "SG"
    Case 16
        Text12.text = "YS"
        Label9.Visible = True
        Combo3.Visible = True
    Case 17
        Text12.text = "GZ"
        Label8.Caption = "数量(页)"
    Case 18
        Combo4.Visible = True
        Text12.text = Combo4.text
        Label8.Caption = "数量(页)"
    Case 19
        Text12.text = "SJ"
        Label8.Caption = "数量(页)"
    Case 20
        Text12.text = "GS"
        Label8.Caption = "数量(页)"
    Case 21
        Text12.text = "HB"
        Label8.Caption = "数量(页)"
    Case 22
        Text12.text = "FC"
        Label8.Caption = "数量(页)"
    Case 23
        Text12.text = "GH"
    Case 24
        Text12.text = "JX"
    Case 25
        Text12.text = "PZ"
        Label8.Caption = "数量(页)"
    Case 26
        Text12.text = "HY"
    Case Else
        Text12.text = ""
    End Select
    Text1.MaxLength = 1000
    Text2.MaxLength = 100
    Text3.MaxLength = 24
    Text4.MaxLength = 20
    Text5.MaxLength = 3 '
    Text6.MaxLength = 4
    Text7.MaxLength = 4 '
    Text8.MaxLength = 20
    Text9.MaxLength = 4
    Text10.MaxLength = 4
    Text11.MaxLength = 1000
    Text12.MaxLength = 3
    Text13.MaxLength = 4 '
    
    If flag = "Insert" Then
        Height = Height - 1900
    End If
    If flag = "Modify" Then
        Combo4.Visible = False '专业会计
        rs.Open "select * from T_ARCHIVE_0200_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!CATALOG_CODE <> "" Then
            Text6.text = rs!CATALOG_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
            Text12.text = xml("SORT_CODE")
            Text13.text = xml("SERIES_CODE")
            Text14.text = xml("TOTAL_QUANTITY")
            If xml("IS_SHARING") <> "" Then
                Check1.Value = xml("IS_SHARING")
            End If
        rs.Close
    strSql = "select count(*) from T_ARCHIVE_0200_FILE where FONDS_CODE='" & Text5.text & "' and CATALOG_CODE='" & Text6.text & "' and FILE_NUMBER='" & Text7.text & "' and sort_code='" & Text12.text & "' and series_code='" & Text13.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text3.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_0200_file where flag =1 and FONDS_CODE='" & Text5.text & "' and CATALOG_CODE='" & Text6.text & "' and FILE_NUMBER='" & Text7.text & "' and sort_code='" & Text12.text & "' and series_code='" & Text13.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text3.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")
                            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
            Text14.text = ListView2.ListItems.Count
            rs.Open "update T_ARCHIVE_0200_VOLUME set TOTAL_QUANTITY=" & Text14.text & ",MEDIUM_QUANTITY=" & Text10.text & " where RECORD_SEQUENCE_NUMBER=" & num & "", conn
            '添加记录到列表框
            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