frmmovefile.frm

用vb6.0实现的一个可以通用的企业档案管理系统。

    Else
        ImgPath = Trim(cmbImgPath.Text)
    End If
    strSQL = "SELECT * FROM sys_Image" & _
            " WHERE Img_Path='" & ImgPath & "'"
    If ChkDate.Value = vbChecked Then
        strSQL = strSQL & " AND Img_Import_Date BETWEEN #" & DTPDate1.Value & "# AND #" & DTPDate2.Value & "#"
    End If
    
    Set rstImgPath = New ADODB.Recordset
    rstImgPath.Open strSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
    
    '如果目录下没有文书,则无需移动
    If rstImgPath.RecordCount = 0 Then
        MsgBox "该目录下没有文书,无需移动!请选择其他有文书的目录?!", vbInformation
        cmbImgPath.SetFocus
        Exit Sub
    End If
    
    With rstImgPath
        If Not .EOF Then .MoveFirst
        Do Until .EOF
            If Dir(!Img_Path & !Img_Name) <> vbNullString Then
            
                '复制文件
                FileCopy !Img_Path & !Img_Name, DestPath & !Img_Name
                
                '删除源文件
                Kill (!Img_Path & !Img_Name)
                
                '修改数据库中的相应纪录
                !Img_Path = DestPath
                .Update
                
            Else
                MoveError = True
                Set Fso = CreateObject("Scripting.FileSystemObject")
                Set Fs = Fso.OpenTextFile(App.Path & "\Errorlog.txt", ForAppending, True)
                Call AddErrorLog(rstImgPath, Fs)
                Fs.Close
            End If
            .MoveNext
        Loop
    End With
    rstImgPath.Close
    
    '察看文件转移过程中出错信息
    If Dir(App.Path & "\ErrorLog.txt") <> vbNullString And MoveError Then
        Msg = MsgBox("在文件转移过程中,出现错误,要察看错误日志吗?", vbYesNo + vbInformation)
        Select Case Msg
            Case vbYes
                Dim fErrorLog As frmErrorLog
                Set fErrorLog = New frmErrorLog
                fErrorLog.rtbError.FileName = App.Path & "\ErrorLog.txt"
                fErrorLog.Show vbModal
            Case vbNo
                MsgBox "转移完成,但是有错误,您可以在以后察看错误日志!", vbInformation
        End Select
    Else
        MsgBox "转移完成!", vbInformation
    End If
    
    '将目标目录加入sys_Path表中
    rstImgPath.Open "SELECT * FROM sys_Path WHERE Img_Path='" & DestPath & "'", conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
    With rstImgPath
        .MoveFirst: .MoveLast
        If .RecordCount = 0 Then
            .AddNew
            !Img_Path = DestPath
            .Update
        End If
    End With

    '刷新cmbImgPath中的文书存放路径
    cmbImgPath.Clear
    With rstImgPath
        .MoveFirst
        cmbImgPath.AddItem Space(20)
        Do Until .EOF
            cmbImgPath.AddItem !Img_Path
            .MoveNext
        Loop
        cmbImgPath.Text = cmbImgPath.List(0)
    End With
    rstImgPath.Close
    
    '刷新lvwDiskSpace中的项目
    Call AddPathInfo
    
End Sub

Private Sub Drive_Change()
    On Error GoTo ErrorHandler
        DirPath.Path = Drive.Drive
Exit Sub
ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbCritical
        Err.Clear
    End If
End Sub

Private Sub Form_Load()
    On Error Resume Next
    
    '初始化所属时期
    txtSSSQ1 = Year(DateAdd("M", -1, Date)) & Format(Month(DateAdd("M", -1, Date)), "0#")
    txtSSSQ2 = Year(Date) & Format(Month(Date), "0#")
    txtSSSQ1.BackColor = &H8000000F
    txtSSSQ2.BackColor = &H8000000F
    txtSSSQ1.Enabled = False
    txtSSSQ2.Enabled = False
    
    '初始化导入日期
    DTPDate1.Format = dtpLongDate
    DTPDate2.Format = dtpLongDate
    DTPDate1.Value = DateAdd("M", -1, Date)
    DTPDate2.Value = Date
    
    '连接数据库
    Set rstImgPath = New ADODB.Recordset
    Set conCaseMain = New ADODB.Connection
    conCaseMain.Provider = csProvider
    conCaseMain.CursorLocation = adUseServer
    conCaseMain.ConnectionTimeout = 60
    
    conCaseMain.Open App.Path & csConCaseMain
    
    '在cmbImgPath中添加文书存放路径
    rstImgPath.Open "SELECT * FROM sys_Path", conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
    With rstImgPath
        .MoveFirst
        cmbImgPath.AddItem Space(20)
        Do Until .EOF
            If Trim(!Img_Path) <> vbNullString Then
                cmbImgPath.AddItem !Img_Path
            End If
            .MoveNext
        Loop
        cmbImgPath.Text = cmbImgPath.List(0)
    End With
    rstImgPath.Close
    
    '初始化Dir路径
    Drive.Drive = Left(App.Path, 2)
    Drive.Drive = GetSetting(App.Title, "Settings", "Drive", Left(App.Path, 2))
    DirPath.Path = GetSetting(App.Title, "Settings", "DirPath", Drive.Drive)
    
    '在lvwDiskSpace中添加列标题
    lvwDiskSpace.View = lvwReport
    lvwDiskSpace.ColumnHeaders.Add , , "文书存放路径", 1800
    lvwDiskSpace.ColumnHeaders.Add , , "数量", 600
    lvwDiskSpace.ColumnHeaders.Add , , "文件占用空间", 1300
    lvwDiskSpace.ColumnHeaders.Add , , "驱动器剩余空间", 1500
    
    '在lvwDiskSpace中添加列
    Call AddPathInfo
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveSetting App.Title, "Settings", "Drive", Drive.Drive
    SaveSetting App.Title, "Settings", "DirPath", DirPath.Path
End Sub

Private Sub UpDown1_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ1, 4) & "/" & Right(txtSSSQ1, 2) & "/01")
    txtSSSQ1.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDown1_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ1, 4) & "/" & Right(txtSSSQ1, 2) & "/01")
    txtSSSQ1.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Sub UpDown2_DownClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ2, 4) & "/" & Right(txtSSSQ2, 2) & "/01")
    txtSSSQ2.Text = Year(DateAdd("M", -1, tmpDate)) & Format(Month(DateAdd("M", -1, tmpDate)), "0#")
End Sub

Private Sub UpDown2_UpClick()
    Dim tmpDate As String
    
    tmpDate = DateValue(Left(txtSSSQ2, 4) & "/" & Right(txtSSSQ2, 2) & "/01")
    txtSSSQ2.Text = Year(DateAdd("M", 1, tmpDate)) & Format(Month(DateAdd("M", 1, tmpDate)), "0#")
End Sub

Private Sub AddPathInfo()
'********************************************************
'功能：
'
'********************************************************
Dim BytesPerSector As Long
Dim SectorsPerCluster As Long
Dim NumberOfFreeClusters As Long
Dim TotalNumberOfClusters As Long

Dim TotalFileSize As Long
Dim TotalFreeSpace As Long

Dim i As Integer
Dim strSQL As String
Dim XItem As MSComctlLib.ListItem

If lvwDiskSpace.ListItems.Count > 0 Then
    lvwDiskSpace.ListItems.Clear
End If

For i = 0 To cmbImgPath.ListCount - 1

    If Trim(cmbImgPath.List(i)) <> vbNullString Then
        
        GetDiskFreeSpace Left(cmbImgPath.List(i), 3), SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TotalNumberOfClusters
        TotalFreeSpace = BytesPerSector * SectorsPerCluster * NumberOfFreeClusters

        strSQL = "SELECT COUNT(Img_Name) AS FileNum " & _
                "FROM sys_Image " & _
                "WHERE Img_Path='" & cmbImgPath.List(i) & "'"
        rstImgPath.Open strSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
        With rstImgPath
            If Not .BOF Then .MoveFirst
            Do Until .EOF
                Set XItem = lvwDiskSpace.ListItems.Add(Text:=cmbImgPath.List(i))
                    XItem.SubItems(1) = !FileNum
                    XItem.SubItems(3) = CStr(Round(TotalFreeSpace / (1024 ^ 2) * 10) / 10) & "M"
                .MoveNext
            Loop
        End With
        rstImgPath.Close
    End If
Next i

For i = 0 To cmbImgPath.ListCount - 1

    If Trim(cmbImgPath.List(i)) <> vbNullString Then
        strSQL = "SELECT Img_Name,Img_Path " & _
                "FROM sys_Image " & _
                "WHERE Img_Path='" & cmbImgPath.List(i) & "'"
            
        rstImgPath.Open strSQL, conCaseMain, adOpenStatic, adLockOptimistic, adCmdText
    
        TotalFileSize = ImgFileSize(rstImgPath)
        If TotalFileSize > (1024 ^ 2) Then
            lvwDiskSpace.ListItems(i).SubItems(2) = CStr(Round(TotalFileSize / (1024 ^ 2) * 10) / 10) & "M"
        Else
            lvwDiskSpace.ListItems(i).SubItems(2) = CStr(Round(TotalFileSize / 1024)) & "K"
        End If
        rstImgPath.Close
    End If
Next i

End Sub

Private Function ImgFileSize(rstTemp As ADODB.Recordset) As Long

    Dim nLen As Long
    
    With rstTemp
        If Not .BOF Then .MoveFirst
        Do Until .EOF
            If Dir(!Img_Path & !Img_Name) <> vbNullString Then
                nLen = nLen + FileLen(!Img_Path & !Img_Name)
            End If
            .MoveNext
        Loop
    End With
    
ImgFileSize = nLen

End Function

Private Sub AddErrorLog(rstImgPath As ADODB.Recordset, Fs)

Dim strTemp As String

With rstImgPath
    If !Img_IsRegister Then
        strTemp = "文件未找到, 所属单位: " & !Nsrmc & vbCrLf & _
                  "            文书类型: " & !Img_Case_Code & vbCrLf & _
                  "            文 件 名: " & !Img_Name & vbCrLf & _
                  "            路    径: " & !Img_Path & vbCrLf
    Else
        strTemp = "文件未找到, 所属单位: " & !Nsrmc & vbCrLf & _
                  "            文书类型: " & !Img_Case_Code & vbCrLf & _
                  "            文 件 名: " & !Img_Name & vbCrLf & _
                  "            所属时期: " & !Img_SSSQ & vbCrLf & _
                  "            路    径: " & !Img_Path & vbCrLf
    End If
End With

Fs.WriteLine (strTemp)

End Sub