【发布时间】：2020-07-15 18:23:12
【问题描述】：
我正在建立一个数据库，项目可以在其中包含某些附件。 主要是 PDF。
很高兴知道：
- 前端访问
- 后端 MySQL
- ODBC 连接
我的目标是使用附件字段来获取文件。然后将此文件导出到网络存储上的生成文件夹。成功导出文件后，附件将被删除并创建超链接。
对于生成的文件夹，我的意思是： f.e.一个名为“Constructionsite_A”的项目，导出创建了这个
C:\Constructionsites\ Constructionsite_A
所有相关的 PDF 都在这个文件夹中。
此代码正在生成一个具有正确名称的特定文件夹（建筑工地 A/B/c 等）。如果该文件夹已经存在，它只是将更多文件粘贴到其中。所以导出功能正在工作！
Public Sub AttachmentToDisk(strTableName As String, _
strAttachmentField As String, strPrimaryKeyFieldName As String)
Dim strFileName As String
Dim db As DAO.Database
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
Dim fld As DAO.Field2
Dim strPath As String
strPath = SpecialFolderPath("Desktop") & "\"
Set db = CurrentDb
Set rsParent = db.OpenRecordset(strTableName, dbOpenSnapshot)
With rsParent
If .RecordCount > 0 Then .MoveFirst
While Not .EOF
' our picture is in the field "pics"
Set rsChild = rsParent(strAttachmentField).Value
If rsChild.RecordCount > 0 Then rsChild.MoveFirst
While Not rsChild.EOF
' this is the actual image content
Set fld = rsChild("FileData")
' create full path and filename
strFileName = strPath & .Fields(strPrimaryKeyFieldName) & "\" & rsChild("FileName")
' take variable to create Path to given textbox
Forms![Formular1]![Hyperlink] = strFileName
' create directory if it does not exists
If Len(Dir(strPath & .Fields(strPrimaryKeyFieldName), vbDirectory)) = 0 Then VBA.MkDir strPath & .Fields(strPrimaryKeyFieldName)
' remove any previous picture from disk it there is any
If Len(Dir(strFileName)) <> 0 Then Kill strFileName
' save our picture to disk
fld.SaveToFile strFileName
' move to next attachment
rsChild.MoveNext
Wend
' move record pointer of parent
.MoveNext
Wend
End With
Set fld = Nothing
Set rsChild = Nothing
Set rsParent = Nothing
Set db = Nothing
End Sub
Forms![Formular1]![Hyperlink] = strFileName
- 这为我提供了一个指向名为 Hyperlink 的给定 Tetxbox 的超链接 但它是静态的，可以将一个超链接粘贴到其中。 -> 在 PDF_B 输入一些文件时，Modul 会尝试将链接粘贴到第一个文本框 ofc。我不知道将其修复为动态的。
按钮“导出和创建链接”的点击事件是
Private Sub Befehl3_Click()
Me.Hyperlink = Null ' Reset textbox
Call AttachmentToDisk("tbl_AuftragsDaten", "testpdf", "KostenstellenZahl")
End Sub
按照“删除附件”的代码
- 此按钮用于测试。
- 如果“删除代码”有效，我想一键导出、创建链接和删除附件，所以我的表格中只需要一个附件字段而不是 3 个（对于 PDF_A/B/三）
Private Sub Befehl12_Click()
On Error GoTo err_proc
Dim strSQL As String
Dim intPic As Integer
DoCmd.RunCommand acCmdSaveRecord
Me.Refresh 'New line
Me.Attachment1.Requery 'New line ' Attachment1 = attachmentbox in form
intPic = Me.Attachment1.CurrentAttachment
' Instantiate the parent recordset.
Dim db As DAO.Database
Dim qdf As DAO.QueryDef, rst1 As DAO.Recordset, rst2 As DAO.Recordset
' testpdf = Name of table field for Attachments in tbl_AuftragsDaten. Primary Key= KostenstellenID
strSQL = "SELECT testpdf FROM tbl_AuftragsDaten WHERE KostenstellenID=" & Me.Text8
Set db = CurrentDb
Set qdf = db.CreateQueryDef("", strSQL)
Set rst1 = qdf.OpenRecordset
If rst1.EOF = True Then GoTo exit_proc
rst1.MoveFirst
rst1.Edit
' Instantiate the child recordset.
Set rst2 = rst1.Fields("Attachment1").Value
rst2.OpenRecordset
If rst2.EOF = True Then GoTo exit_proc
rst2.MoveFirst
If intPic > 0 Then rst2.Move intPic
rst2.Delete
' Update the parent record
rst1.Update
Me.Attachment1.Requery
DoCmd.RunCommand acCmdSaveRecord
exit_proc:
On Error Resume Next
rst2.Close
rst1.Close
qdf.Close
Set db = Nothing
Exit Sub
err_proc:
MsgBox Err.Description
Resume exit_proc
End Sub
通常它应该删除附件，但我收到以下错误
运行时错误 3265 - 在此集合中找不到项目
尝试使用此代码进行错误处理，但我没有摆脱错误...
Select Case Err.Number
Case 3265
Resume Next
在寻找其他解决方法后进行编辑
Option Explicit
Option Compare Database
Public Function FCopy(strTableName As String, _
strPrimaryKeyFieldName As String) As String
Dim fDialog As Office.FileDialog
Dim strPath As String
Dim db As DAO.Database
Dim rsPK As DAO.Recordset2
Dim strFileName As String
Dim File_Name As String
Dim FD As FileDialog
strPath = "C:\Users\Felix\Desktop\Neuer Ordner" & "\"
Set db = CurrentDb
Set rsPK = db.OpenRecordset(strTableName, dbOpenSnapshot)
strFileName = strPath & rsPK.Fields(strPrimaryKeyFieldName) & "\"
' Set up the File Dialog. '
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
' FD.InitialFileName = Application.CurrentProject.path
With fDialog
' Allow user to make multiple selections in dialog box '
.AllowMultiSelect = False
' Set the title of the dialog box. '
.Title = "Please select a file"
' Clear out the current filters, and add our own.'
.Filters.Clear
.Filters.Add "All Files", "*.*"
' Show the dialog box. If the .Show method returns True, the '
' user picked at least one file. If the .Show method returns '
' False, the user clicked Cancel. '
If .Show = True Then
FCopy = fDialog.SelectedItems(1)
Else
Exit Function
End If
End With
File_Name = Dir(FCopy)
' create directory if it does not exists
If Len(Dir(strPath & rsPK.Fields(strPrimaryKeyFieldName), vbDirectory)) = 0 Then VBA.MkDir strPath & rsPK.Fields(strPrimaryKeyFieldName)
FileCopy File_Name, strFileName & File_Name
Set FD = Nothing
End Function
这会将文件复制到文件夹中。但该文件夹始终由表的第一个 PrimaryKey 生成。我没有得到它在我的表单中获取当前记录的当前 PrimaryKey...
感谢您的帮助！
【问题讨论】：
-
为什么是两个程序？为什么不是提取、删除、保存文本的 1 个程序？每条记录中是否只有 1 个附件？
-
是否要将保存在同一记录附件中的超链接字符串从其中删除？
-
为什么要使用附件字段开头？您如何使用它来“获取文件”？从哪里来？
-
因为测试的原因，我把它分成了两个程序。而且我不知道如何结合这两个程序，所以我有 2.. 是的，它有点肮脏的风格。是的，我想将超链接字符串保存到删除附件的同一记录中。一条记录可以有多个指向多个文件的超链接，但一次只能附加一个文件。我使用附件字段首先通过文件资源管理器导入文件。我不知道我不必使用它的方法。最好只是复制而不需要从数据库中删除文件，因为它从来没有在那里
-
该文件将是本地文件，必须复制到网络文件夹