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

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