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