form_wenshuv.frm

2008年版

    '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\gridF.xls"
        strDestination = App.Path & "excel\temp.xls"
    Else
        strSource = App.Path & "\excel\gridF.xls"
        strDestination = App.Path & "\excel\temp.xls"
    End If
'    ElseIf A4 = "16K" Then
'        strSource = App.Path & "\excel2\gridF.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
    'xlsheet.Cells(8, 3) = Text5.text + "   " + Text6.text + "   " + Text7.text
        
    Set xlsheet = xlbook.Worksheets(2)
    'xlsheet.Cells(1, 1) = "卷内文件目录"
    lop = 3
'    For numj = 1 To ListView2.ColumnHeaders.Count
'    xlsheet.Cells(2, numj) = ListView2.ColumnHeaders.Item(numj).Text
'    Next numj
        With ListView2.ListItems
    For numi = 1 To .Count
        xlsheet.Cells(lop, 1) = .Item(numi)
        For numj = 1 To ListView2.ColumnHeaders.Count - 1
        If numj <> 5 Then
            xlsheet.Cells(lop, numj + 1) = .Item(numi).SubItems(numj) '打印列
        End If
        If numj = 5 Then
            xlsheet.Cells(lop, 6) = .Item(numi).SubItems(numj - 1)  '责任者题名互换
        End If
        If numj = 6 Then
            xlsheet.Cells(lop, 5) = .Item(numi).SubItems(numj - 1)
        End If
        Next numj
        lop = lop + 1
    Next numi
    
    Dim isum, iprint As Integer
    isum = .Count
        iprint = isum Mod 10
        If iprint <> 0 Then
            iprint = 10 - 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 + "-" + Text6.text + "-" + Text7.text
    xlsheet.Cells(3, 4) = Text3.text
    xlsheet.Cells(4, 4) = ""
    xlsheet.Cells(18, 4) = "'" + Text1.text
    xlsheet.Cells(20, 4) = "'" + Text4.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 = 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.Label4.Caption + "目录信息"
    Label1.backColor = bgColor
    
    Combo1.AddItem "公开"
    Combo1.AddItem "限制"
    Combo1.AddItem "秘密"
    Combo1.AddItem "机密"
    Combo1.ListIndex = 1
    
    Combo2.AddItem "永久"
    Combo2.AddItem "长期"
    Combo2.AddItem "短期"
    Combo2.ListIndex = 0
    
        Text1.text = ""
        Text2.text = ""
        Text3.text = ""
        Text4.text = ""
        Text5.text = fondsCode
        Text6.text = "" '目录号
        Text7.text = "" '案卷号
        Text8.text = ListView2.ListItems.Count
        Text9.text = 0
        Text10.text = ""
        Text11.text = ""
        Text12.text = ""
        DTPicker1.Value = Date
        DTPicker2.Value = Date
        DTPicker3.Value = Date
    If flag = "Insert" Then
        Height = Height - 1900
    End If
    If flag = "Modify" Then
        rs.Open "select * from T_ARCHIVE_0100_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!office_name <> "" Then
             Text4.text = rs!office_name
            End If
            If rs!describing_date <> "" Then
             DTPicker1.Value = rs!describing_date
            End If
            If rs!PERSON_FOR_DESCRIPTION <> "" Then
             Text10.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!DATE_BEGUN <> "" Then
             DTPicker2.Value = rs!DATE_BEGUN
            End If
            If rs!DATE_FINISHED <> "" Then
             DTPicker3.Value = rs!DATE_FINISHED
            End If
            If rs!TOTAL_QUANTITY <> "" Then
             Text8.text = rs!TOTAL_QUANTITY
            End If
            If rs!medium_quantity <> "" Then
             Text9.text = rs!medium_quantity
            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!NOTES_OF_ARCHIVIST <> "" Then
             Text11.text = rs!NOTES_OF_ARCHIVIST
            End If
            If rs!ARCHIVE_YEAR <> "" Then
                Text12.text = rs!ARCHIVE_YEAR
            End If
            If xml("IS_SHARING") <> "" Then
                Check1.Value = xml("IS_SHARING")
            End If
        rs.Close
        If Text6.text = "" Then
            Text6.text = "-1"
        End If
        If Text7.text = "" Then
            Text7.text = "-1"
        End If
        strSql = "select count(*) from T_ARCHIVE_0100_FILE where FONDS_CODE='" & Text5.text & "' and SERIES_CODE=" & Text6.text & " and FILE_NUMBER=" & Text7.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
                
            Else
        With ListView2
                .ColumnHeaders.Clear
                .ColumnHeaders.Add , , "序号", 600
                .ColumnHeaders.Add , , "唯一号", 0
                .ColumnHeaders.Add , , "室编档号", 1500
                .ColumnHeaders.Add , , "文件编号", 1200
                .ColumnHeaders.Add , , "题名", 3500
                .ColumnHeaders.Add , , "责任者", 1500
                .ColumnHeaders.Add , , "日期", 2000
                .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_0100_file where flag =1 and FONDS_CODE='" & Text5.text & "' and SERIES_CODE=" & Text6.text & " and FILE_NUMBER=" & Text7.text & " and REFERENCE_CODE_OF_FILE_OFFICE='" & Text3.text & "' order by number_of_page"
                Text9.Visible = False
                ListView2.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("REFERENCE_CODE_OF_FILE_OFFICE")
                        itmX.SubItems(3) = xml("DOCUMENT_CODE")
                         itmX.SubItems(4) = xml("TITLE_PROPER")
                        itmX.SubItems(5) = xml("PRIMARY_CREATOR")
                        itmX.SubItems(6) = Replace(xml("DATE_BEGUN"), "-", " ")
                            itmX.SubItems(7) = Format(CStr(i + 1), "000") + " - " + Format(CStr(i + CLng(xml("item_number"))), "000")
                            Text9.text = Format(CStr(i + CLng(xml("item_number"))), "000")
                        itmX.SubItems(8) = xml("NOTES_OF_ARCHIVIST")
                    i = i + CLng(xml("item_number"))
                    rs.MoveNext
                Wend
                rs.Close
                '添加记录到列表框
                Text9.Visible = True
                ListView2.Visible = True
                Text8.text = ListView2.ListItems.Count
                rs.Open "update T_ARCHIVE_0100_VOLUME set TOTAL_QUANTITY=" & Text8.text & ",MEDIUM_QUANTITY=" & Text9.text & " where RECORD_SEQUENCE_NUMBER=" & num & "", conn

            End If
    End If
    If Text6.text = "-1" Then
        Text6.text = ""
    End If
    If Text7.text = "-1" Then
        Text7.text = ""
    End If
    Text1.MaxLength = 1000
    Text2.MaxLength = 100
    Text3.MaxLength = 24
    Text4.MaxLength = 255
    Text5.MaxLength = 3 '
    Text6.MaxLength = 2 '
    Text7.MaxLength = 4 '
    Text8.MaxLength = 24
    Text9.MaxLength = 24
    Text10.MaxLength = 20
    Text11.MaxLength = 1000
    Text12.MaxLength = 4
    strfile = Text3.text
End Sub

Private Sub ListView2_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
Dim i As Integer
    With ListView2
        If ColumnHeader.Index = 1 Then
            Dim bValue As Boolean
            
            bValue = Not .ListItems(1).Checked
            For i = 1 To .ListItems.Count
                .ListItems(i).Checked = bValue
            Next i
        Else
            For i = 2 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 If
    End With
End Sub

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