form_mediav.frm

2008年版

End Sub

Private Sub Command3_Click()
Dim i As Integer
If MsgBox("确实要移除吗？", vbYesNo + vbQuestion, "") = vbYes Then
    rs.Open "update T_ARCHIVE_0201_FILE set flag=0,FONDS_CODE='',CATALOG_CODE='',FILE_NUMBER='',sort_code='',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 Command4_Click()
    On Error GoTo e:
 '   form_PK.Show 1
    Dim xlapp As Object, xlbook As Object, xlsheet As Object
    Dim strSource, strDestination As String
    Dim lop As Integer
    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) = "                      '" & 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
    
    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 "AVI"
    Combo3.AddItem "MPEG"
    Combo3.AddItem "RM"
    Combo3.AddItem "WAV"
    Combo3.ListIndex = 0
    
    Text1.text = ""
    Text2.text = ""
    Text3.text = ""
    Text4.text = ""
    Text5.text = fondsCode
    Text6.text = 0
    Text7.text = 0
    Text8.text = ""
    Text9.text = ""
    Text10.text = 0
    Text11.text = ""
    Text12.text = 0
    Text13.text = 0
    Text14.text = "SX"
    Text14.Enabled = False '分类号
    Text15.text = ""
    DTPicker1.Value = Date
    DTPicker2.Value = Date
    DTPicker3.Value = Date
    
    
    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 = 6
    Text13.MaxLength = 10
    Text14.MaxLength = 3
    Text15.MaxLength = 2 '
    
    If flag = "Insert" Then
        Height = Height - 1900
    End If
    If flag = "Modify" Then
        rs.Open "select * from T_ARCHIVE_0201_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!file_MEDIUM <> "" Then
            Text4.text = rs!file_MEDIUM
            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!NOTES_OF_ARCHIVIST <> "" Then
            Text11.text = rs!NOTES_OF_ARCHIVIST
            End If
            If rs!QUANTITY <> "" Then
             Text12.text = rs!QUANTITY
            End If
            If rs!medium_quantity <> "" Then
             Text10.text = rs!medium_quantity
            End If
            If rs!FILE_SIZE <> "" Then
             Text13.text = rs!FILE_SIZE
            End If
            If rs!FILE_TYPE <> "" Then
             Combo3.text = rs!FILE_TYPE
            End If
            Text14.text = xml("SORT_CODE")
            Text15.text = xml("SERIES_CODE")
            If xml("IS_SHARING") <> "" Then
                Check1.Value = xml("IS_SHARING")
            End If
        rs.Close
    strSql = "select count(*) from T_ARCHIVE_0201_FILE where FONDS_CODE='" & Text5.text & "' and CATALOG_CODE='" & Text6.text & "' and FILE_NUMBER='" & Text7.text & "' and sort_code='" & Text14.text & "' and series_code='" & 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 rs.Fields(0).Value
            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 As Integer
                i = 0
                strSql = "select * from t_archive_0201_file where flag =1 and FONDS_CODE='" & Text5.text & "' and CATALOG_CODE='" & Text6.text & "' and FILE_NUMBER='" & Text7.text & "' and sort_code='" & Text14.text & "' and series_code='" & Text15.text & "' and REFERENCE_CODE_OF_FILE_OFFICE='" & Text3.text & "' order by referenced_code"
                rs.Open strSql, conn
                While Not rs.EOF
                i = i + 1
                    Set itmX = ListView2.ListItems.Add(, , i)
                        itmX.SubItems(1) = rs.Fields(0).Value
                        itmX.SubItems(2) = xml("reference_code_of_file_office")
                        itmX.SubItems(3) = xml("TITLE_PROPER")
                        itmX.SubItems(4) = xml("PRIMARY_CREATOR")
                        itmX.SubItems(5) = xml("DATE_BEGUN")
                        itmX.SubItems(6) = xml("referenced_code")
                        itmX.SubItems(7) = xml("NOTES_OF_ARCHIVIST")
                    rs.MoveNext
                Wend
                rs.Close
            '添加记录到列表框
            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