网站公告
·Access快速平台QQ群号:189307860    ·Access快速开发平台下载地址及教程    ·欢迎添加微信交流账号:Accessoft7    ·如何快速搜索本站文章|示例|资料!    
您的位置: 首页 > 技术文章 > access开发平台

自动删除 平台通用附件产生的多余(无用)文件

时 间:2017-04-01 23:42:37
作 者:陈绪银   ID:27618  城市:淮安
摘 要:平台附件使用中,经常产生无用的多余文件,占用磁盘空间,也不便于查阅。产生无用文件的操作主要有下述几种:
1、新增 ---> 添加 ---> 取消或关闭       ==》 产生:{XXXXXXX XXXXX ...}.???  文件
2、编辑 ---> 添加 ---> 取消或关闭       ==》 产生:XXXXXXX_XXXXXXXX.???   文件
3、替换、删除功能,旧文件仍在附件文件夹中。
代码修改后,自动删除这些文件,并立即更新附件表 Sys_Attachments 避免显示文件被删除。
另以拷贝的方式打开附件文档,避免附件文档被修改。
代码如下,仅供参考:

正 文:

Option Compare Database
Option Explicit

Public Function LoadAttachmentData(DataCategory As String _
                                 , DataID As Variant _
                                 , Optional ActiveConnection As Variant _
                                  )
    On Error GoTo ErrorHandler
   
    Me.txtDataCategory.Tag = DataCategory
    Me.txtDataID.Tag = Nz(DataID)
    Dim strSQL As String: strSQL = " Select * FROM [Sys_Attachments]" _
                                 & " Where [DataCategory]='" & DataCategory & "' AND DataID='" & DataID & "'"
    Dim rst As Object
    If IsMissing(ActiveConnection) Then
        Set rst = OpenADORecordset(strSQL, , CurrentProject.Connection)
    Else
        Set rst = OpenADORecordset(strSQL, , ActiveConnection)
    End If
    Me.OnCurrent = ""
    Me.RecordSource = Replace(strSQL, "[Sys_Attachments]", "[TMP_Attachments]")
    Dim blnAllowEdits As Boolean: blnAllowEdits = Me.AllowEdits
    Me.AllowEdits = True
    Me.AllowAdditions = True
    Me.AllowDeletions = True
    Dim rstTmp As Object: Set rstTmp = Me.Recordset
    Do Until rstTmp.EOF
        rstTmp.Delete
        rstTmp.MoveNext
    Loop
    Do Until rst.EOF
        rstTmp.AddNew
        rstTmp![DataCategory] = rst![DataCategory]
        rstTmp![DataID] = rst![DataID]
        rstTmp![AttachmentName] = rst![AttachmentName]
        rstTmp.Update
        rst.MoveNext
    Loop
    rst.Close
    Me.AllowEdits = blnAllowEdits
    Me.AllowAdditions = blnAllowEdits
    Me.AllowDeletions = blnAllowEdits
    Me.btnAdd.Enabled = blnAllowEdits
    Me.btnReplace.Enabled = blnAllowEdits
    Me.btnDelete.Enabled = blnAllowEdits

ExitHere:
    Me.OnCurrent = "[Event Procedure]"
    Me.Requery
    Set rst = Nothing
    Set rstTmp = Nothing
    Exit Function
   
ErrorHandler:
    RDPErrorHandler Me.Name & ": Function LoadAttachmentData()"
    Resume ExitHere
End Function

Public Function SaveAttachmentData(DataCategory As String _
                                 , DataID As Variant _
                                 , Optional ActiveConnection As Variant _
                                   )
    On Error GoTo ErrorHandler
   
    Dim strSQL As String
    strSQL = "Select * FROM [Sys_Attachments] Where [DataCategory]='" & DataCategory & "' AND DataID='" & DataID & "'"
    Dim rst As Object
    If IsMissing(ActiveConnection) Then
        Set rst = OpenADORecordset(strSQL, adLockOptimistic, CurrentProject.Connection)
    Else
        Set rst = OpenADORecordset(strSQL, adLockOptimistic, ActiveConnection)
    End If
    Do Until rst.EOF
        rst.Delete
        rst.MoveNext
    Loop
   
    If Me.txtDataID.Tag <> DataID Then
        Me.Requery
        Dim rstTmp As Object: Set rstTmp = Me.Recordset
        Do Until rstTmp.EOF
            Dim strNewName As String: strNewName = DataID & Mid(rstTmp!AttachmentName, Len(Me.txtDataID.Tag) + 1)
            If Dir(Me.txtAttachmentPath & rstTmp!AttachmentName) <> "" Then
                If Len(Me.txtDataID.Tag) = 38 And Me.txtDataID.Tag Like "{*}" Then
                    Name Me.txtAttachmentPath & rstTmp!AttachmentName As Me.txtAttachmentPath & strNewName
                Else
                    CopyFile Me.txtAttachmentPath & rstTmp!AttachmentName, Me.txtAttachmentPath & strNewName
                End If
            End If
            rstTmp.Edit
            rstTmp!AttachmentName = strNewName
            rstTmp.Update
            rstTmp.MoveNext
        Loop
    End If
    Me.Refresh

    Set rstTmp = Me.Recordset.Clone
    Do Until rstTmp.EOF
        rst.AddNew
        rst![DataCategory] = DataCategory
        rst![DataID] = DataID
        rst![AttachmentName] = rstTmp![AttachmentName]
        rst.Update
        rstTmp.MoveNext
    Loop
    rst.Close

ExitHere:
    Set rst = Nothing
    Set rstTmp = Nothing
    Exit Function

ErrorHandler:
    RDPErrorHandler Me.Name & ": Function SaveAttachmentData()"
    Resume ExitHere
End Function

Private Sub Form_Close()
    Rem chenxuyin add start *****************************
    Dim strSQL        As String
    Dim cnn           As Object 'ADODB.Connection
    Dim rst           As Object 'ADODB.Recordset
    Dim strAttachmentNames As String
   
    Dim strWildcardName As String '文件名通配部分
    Dim strFileNames() As String  '文件全名数组
    Dim DestinationPath As String '目标路径
    Dim DestinationFullName As String '目标全名
    Dim intI As Integer
   
    If Not Me.txtDataID.Tag = "" Then
       
        Set cnn = CurrentProject.Connection
        strSQL = "Select [AttachmentName] FROM [TMP_Attachments]"
        Set rst = OpenADORecordset(strSQL, adLockOptimistic, cnn)
        Do Until rst.EOF
            strAttachmentNames = strAttachmentNames & rst![AttachmentName] & ";"
            rst.MoveNext
        Loop
        rst.Close
       
        strWildcardName = Me.txtAttachmentPath & Me.txtDataID.Tag & "*"
        If Dir(strWildcardName) <> "" Then
            intI = 1
            ReDim strFileNames(intI)
            Do While Dir() <> ""    ' 开始循环。
                intI = intI + 1
                ReDim strFileNames(intI)
            Loop
            If UBound(strFileNames) > 0 Then
                strFileNames(1) = Dir(strWildcardName)
                For intI = 2 To UBound(strFileNames)
                    strFileNames(intI) = Dir()
                Next intI
            End If
            For intI = 1 To UBound(strFileNames)
                If CountStr(strAttachmentNames, strFileNames(intI)) = 0 Then
                    Kill Me.txtAttachmentPath & strFileNames(intI)  '删除文件
                End If
            Next intI
        End If
    End If
    Rem add end *****************************************
End Sub

Private Sub Form_Open(Cancel As Integer)
    Me.OnCurrent = ""
    CurrentDb.Execute "Delete FROM TMP_Attachments"
    Me.OnCurrent = "[Event Procedure]"
    Me.RecordSource = "TMP_Attachments"
End Sub

Private Sub Form_Load()
    LoadLocalLanguage Me
    ApplyTheme Me
    Me.txtAttachmentPath = GetParameter("Attachment Path", dbText, "", , , True)
    If Len(Nz(Me.txtAttachmentPath)) = 0 Then Me.txtAttachmentPath = CurrentProject.Path & "\Attachments\"
    If Left(Me.txtAttachmentPath, 2) = ".\" Then Me.txtAttachmentPath = CurrentProject.Path & Mid(Me.txtAttachmentPath, 2)
    If Right(Me.txtAttachmentPath, 1) <> "\" Then Me.txtAttachmentPath = Me.txtAttachmentPath & "\"
    Rem chenxuyin add start *************************************
    If Dir(Me.txtAttachmentPath & "{*") <> "" Then
        PathfileOperation foDelete, Me.txtAttachmentPath & "{*"
    End If
    Rem add end *************************************************
End Sub

Private Sub Form_Current()
    On Error Resume Next
    Dim rst As Object

    Me.imgPictureView.Picture = ""
    Me.lblPrompt.Caption = ""
    Me.btnDelete.Enabled = (Me.AllowEdits And (Not Me.NewRecord))
   
    If Me.NewRecord Then
        Me.txtNum = LoadString("(New)")
    Else
        If IsNull(Me.txtAttachmentName) Then
            Me.lblPrompt.Caption = LoadString("The attachment is empty.")
        Else
            Me.imgPictureView.Picture = Me.txtAttachmentPath & Me.txtAttachmentName
            If IsNull(Me.imgPictureView.PictureData) Then
                If PathFileExists(Me.txtAttachmentPath & Me.txtAttachmentName) Then
                    Me.lblPrompt.Caption = LoadString("Attachment '|' is not picture, can't preview here, please double-click to open view.", "|", Me.txtAttachmentName)
                Else
                    Me.lblPrompt.Caption = LoadString("Attachment '|' not found.", "|", Me.txtAttachmentPath & Me.txtAttachmentName)
                End If
            End If
        End If
        Set rst = Me.RecordsetClone
        rst.MoveLast
        Me.txtNum = Me.CurrentRecord & " / " & rst.RecordCount
    End If
End Sub

Private Sub btnPrevious_Click()
    On Error Resume Next
    Me.Recordset.MovePrevious
    If Me.Recordset.BOF Then Me.Recordset.MoveLast
End Sub

Private Sub btnNext_Click()
    On Error Resume Next
    Me.Recordset.MoveNext
    If Me.Recordset.EOF Then Me.Recordset.MoveFirst
End Sub

Private Sub btnAdd_Click()
    On Error GoTo ErrorHandler

    If Me.txtDataID.Tag = "" Then Me.txtDataID.Tag = GetGUID()

    With FileDialog(msoFileDialogFilePicker)
'        .InitialFileName = Me.txtAttachmentPath
        .Filters.Clear
        .AllowMultiSelect = True
        If Not .Show Then Exit Sub
        CreateMultiDir Me.txtAttachmentPath
        Dim varItem As Variant
        For Each varItem In .SelectedItems
            Rem chenxuyin add start ***************************
            If DCount("*", "TMP_Attachments", "AttachmentName='" & Me.txtDataID.Tag & "_" & Mid(varItem, InStrRev(varItem, "\") + 1) & "'") > 0 Then
                MsgBox "文件【" & Me.txtDataID.Tag & "_" & Mid(varItem, InStrRev(varItem, "\") + 1) & "】已存在,请检查!", vbExclamation, "提示"
            End If
            Rem add end ***************************************
            If Not Me.NewRecord Then
                DoCmd.GoToRecord , , acNewRec
            End If
            Me.txtDataCategory = Me.txtDataCategory.Tag
            Me.txtDataID = Me.txtDataID.Tag
            Me.txtAttachmentName = Me.txtDataID & "_" & Mid(varItem, InStrRev(varItem, "\") + 1)
            If varItem <> Me.txtAttachmentPath & Me.txtAttachmentName Then
                FileCopy varItem, Me.txtAttachmentPath & Me.txtAttachmentName
            End If
            Me.Dirty = False
        Next
        Call Form_Current
    End With

ExitHere:
    Exit Sub
   
ErrorHandler:
    RDPErrorHandler Me.Name & ": Sub btnAdd_Click()"
    Resume ExitHere
End Sub

Private Sub btnReplace_Click()
    On Error GoTo ErrorHandler
    Rem chenxuyin add start ************************************
    Dim strDataCategory As String
    Dim strDataID As String
    Dim strFileName As String
    strDataCategory = Nz(DLookup("DataCategory", "TMP_attachments"), "")
    strDataID = Nz(DLookup("DataID", "TMP_attachments"), "")
    If Not Nz(Me.txtAttachmentName) = "" Then
        strFileName = Me.txtAttachmentPath & Me.txtAttachmentName
    End If
    If MsgBox("此附件文档替换后将删除,且不可恢复,确定要替换?", vbQuestion + vbOKCancel) = vbCancel Then
        Exit Sub
    End If
    Rem add end **************************************************

    With FileDialog(msoFileDialogFilePicker)
'        .InitialFileName = Me.txtAttachmentPath
        .Filters.Clear
        .AllowMultiSelect = False
        If Not .Show Then Exit Sub
        CreateMultiDir Me.txtAttachmentPath
        Me.txtAttachmentName = Me.txtDataID & "_" & Mid(.SelectedItems(1), InStrRev(.SelectedItems(1), "\") + 1)
        If .SelectedItems(1) <> Me.txtAttachmentPath & Me.txtAttachmentName Then
            FileCopy .SelectedItems(1), Me.txtAttachmentPath & Me.txtAttachmentName
        End If
        Me.Dirty = False
        Call Form_Current
    End With

    Rem chenxuyin add start **************************************
    If Not Nz(strDataCategory) = "" Then
        Call SaveAttachmentData(strDataCategory, strDataID, CurrentProject.Connection)
    End If
    If PathFileExists(strFileName) Then
        Kill strFileName
    End If
    Rem add end ************************************************

ExitHere:
    Exit Sub

ErrorHandler:
    RDPErrorHandler Me.Name & ": Sub btnReplace_Click()"
    Resume ExitHere
End Sub

Private Sub btnDelete_Click()
    On Error GoTo ErrorHandler
    Rem chenxuyin add start **************************************
    Dim strDataCategory As String
    Dim strDataID As String
    Dim strFileName As String
    strDataCategory = Nz(DLookup("DataCategory", "TMP_attachments"), "")
    strDataID = Nz(DLookup("DataID", "TMP_attachments"), "")
    If Not Nz(Me.txtAttachmentName) = "" Then
        strFileName = Me.txtAttachmentPath & Me.txtAttachmentName
    End If
    If MsgBox("此附件文档删除后不可恢复,确定要删除?", vbQuestion + vbOKCancel) = vbCancel Then
        Exit Sub
    End If
    Rem add end **************************************************

    DoCmd.SetWarnings False
    RunCommand acCmdDeleteRecord
    DoCmd.SetWarnings True
    Call Form_Current
    Rem chenxuyin add start **************************************
    If Not Nz(strDataCategory) = "" Then
        Call SaveAttachmentData(strDataCategory, strDataID, CurrentProject.Connection)
    End If
    If PathFileExists(strFileName) Then
        Kill strFileName
    End If
    Me.Requery
    Rem add end **************************************************

ExitHere:
    Exit Sub
   
ErrorHandler:
    RDPErrorHandler Me.Name & ": Sub btnDelete_Click()"
    Resume ExitHere
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    Me.imgPictureView.Move Me.imgPictureView.Left, , Me.InsideWidth - 30, Me.InsideHeight - Me.Section(acFooter).Height - 30
    Me.lblPrompt.Move Me.lblPrompt.Left, , Me.imgPictureView.Width - 30, Me.imgPictureView.Height
    Me.lblPrompt.Width = Me.imgPictureView.Width
    Me.txtAttachmentName.Width = Me.InsideWidth
    Me.Section(acDetail).Height = Me.imgPictureView.Height + 30
    Me.btnPrevious.Left = (Me.InsideWidth - Me.btnPrevious.Width - Me.txtNum.Width - Me.btnNext.Width) / 2
    Me.txtNum.Left = Me.btnPrevious.Left + Me.btnPrevious.Width
    Me.btnNext.Left = Me.txtNum.Left + Me.txtNum.Width
    Me.btnAdd.Left = (Me.InsideWidth - Me.btnAdd.Width - Me.btnReplace.Width - Me.btnDelete.Width) / 2
    Me.btnReplace.Left = Me.btnAdd.Left + Me.btnAdd.Width
    Me.btnDelete.Left = Me.btnReplace.Left + Me.btnReplace.Width
End Sub

Private Sub lblPrompt_DblClick(Cancel As Integer)
    Rem chenxuyin add start *************************************
    '以拷贝的方式打开附件文档,避免附件文档被修改。
   
    Dim strMsg              As String '消息文本
    Dim strDestinationName  As String '目标全名
    Dim objWSh              As Object 'WScript.Shell
    Dim strMyDocPath        As String '我的文档
   
    Set objWSh = CreateObject("WScript.Shell")
    strMyDocPath = objWSh.SpecialFolders("Mydocuments")
    strMyDocPath = strMyDocPath & "\"
   
    strDestinationName = "TempFile" & Mid(Me.txtAttachmentName, InStrRev(Me.txtAttachmentName, "."))
   
    If PathFileExists(strMyDocPath & strDestinationName) Then
        If FileLocked(strMyDocPath & strDestinationName) Then
            strMsg = "文件:" & strMyDocPath & strDestinationName & "已经打开,请关闭后再试!"
            MsgBox strMsg, vbExclamation, "提示"
        Else
            Kill strMyDocPath & strDestinationName
        End If
    End If
   
    PathfileOperation foCopy, Me.txtAttachmentPath & Me.txtAttachmentName, _
                              strMyDocPath & strDestinationName
   
    ShellExecute strMyDocPath & strDestinationName
   
    Rem add end *****************************************************************
    Rem ShellExecute Me.txtAttachmentPath & Me.txtAttachmentName '原语句
End Sub




Access快速开发平台QQ群 (群号:189307860)       access源码网店

最新评论 查看更多评论(1)

2017/10/12 12:06:14KevinFan
这个修改得很实用,但是最后一个避免修改附件的,运行到这句出错:If FileLocked(strMyDocPath & strDestinationName) Then,FileLocked子过程或函数未定义,这个是自定义函数还是要添加哪个引用呢?

发表评论您的评论将提升作者分享的动力!快来评论一下吧!

用户名:
密 码:
内 容:
 

常见问答

技术分类

相关资源

关于我们 | 服务条款 | 在线投稿 | 友情链接 | 网站统计 | 网站帮助