寻求其他解决方法后进行编辑

Question

我正在建立一个数据库，其中项目可以具有某些附件。主要是PDF。

很高兴知道：

前端访问
后端MySQL
ODBC连接

我的目的是使用附件字段来获取文件。然后将此文件导出到网络存储上的生成的文件夹中。成功导出文件后，附件将被删除，并且已创建超链接。

对于生成的文件夹，我的意思是： f.e.一个名为“ Constructionsite_A”的项目，导出将创建该项目

C：\ Constructionsites \ Constructionsite_A
所有相关的PDF都位于此文件夹中。

此代码将生成一个具有正确名称的特定文件夹（Construction Site 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

表单！[Formular1]！[超链接] = strFileName

这为我提供了指向名为 Hyperlink 的给定Tetxbox的超链接。但是它是静态的，可以将One Hyperlink粘贴到其中。 ->在PDF_B处输入某些文件时，Modul会尝试将链接粘贴到第一个Textbox ofc中。我不知道将其修复为动态的。

“导出和创建链接”按钮上的点击事件为

Private Sub Befehl3_Click()
Me.Hyperlink = Null ' Reset textbox
Call AttachmentToDisk("tbl_AuftragsDaten", "testpdf", "KostenstellenZahl")
End Sub

遵循“删除附件”的代码

此按钮用于测试。
如果“删除代码”有效，我想一键导出，创建链接并删除附件，所以我只需要表中的一个附件字段，而不是3（对于PDF_A / B / C）

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生成。我不知道以我的形式接受当前记录的当前主键...

感谢帮助！

Answer 1

此代码获取表单中的文件夹名称表单文本框，杀死该文件夹中具有相同名称的文件，复制该文件，将超链接添加到给定的表中，如果该表中已存在超链接，则仅给出一个信息输出，而无需再次添加相同的超链接。变量“ Typ”是超链接的附加信息文本。感谢@ June7提供一些提示！如果有人需要英语评论，请告诉我

Option Explicit
Option Compare Database

 Public Function SelectCopy(Typ As String) As String

    Dim fDialog As Office.FileDialog
    Dim strPath As String
    Dim db As DAO.Database
    Dim strFileName As String
    Dim File_Name As String
    Dim FD As FileDialog
    Dim rstHyper As DAO.Recordset
    Dim strPrimaryKeyFieldName As String

      ' Bezeichnung des Ordners
    strPrimaryKeyFieldName = Forms![Formular1]![KostenstellenZahl]

      ' DefaultPath festlegen
     strPath = "C:\Users\Felix\Desktop\Neuer Ordner" & "\"

      ' Datenbank festlegen für späteren RS aufruf
     Set db = CurrentDb

      ' Dynamischer Ordner wird erstellt
    strFileName = strPath & strPrimaryKeyFieldName & "\"  

      ' Initieren des FileDialogs. '
        Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

      ' FD.InitialFileName = Application.CurrentProject.path
       With fDialog

      ' True False MultiAuswahl
      .AllowMultiSelect = False

      ' Titel der Dialogbox. '
      .Title = "Bitte Datei auswählen"

      ' Alle Filter löschen und eigene setzen.'
      .Filters.Clear
      .Filters.Add "All Files", "*.*"

      ' Dialogbox zeigen. Wenn .Show methode True, der '
      ' Benutzer hat mind. eine Datei ausgewählt. Wenn .Show methode '
      ' False, wurde abgebrochen. '
      If .Show = True Then
        SelectCopy = fDialog.SelectedItems(1)
      Else
        Exit Function
      End If
   End With

   ' Der Ausgeählte Dateiname wird formatiert und gespeichert
   File_Name = Dir(SelectCopy)

       ' Ordner mit den Variablen wird erstellt & vorher formatiert
     If Len(Dir(strPath & strPrimaryKeyFieldName, vbDirectory)) = 0 Then VBA.MkDir strPath & strPrimaryKeyFieldName

      ' Wenn Datei mit Namen vorhanden wird sie gelöscht
        Dim strFile  As String: strFile = strFileName & File_Name
        If Len(Dir$(strFile)) > 0 Then Kill strFile

        ' Datei wird kopiert
        FileCopy File_Name, strFileName & File_Name

       ' Tabelle wird geöffnet um Hyperlink hinzuzufügen
       Set rstHyper = db.OpenRecordset("tbl_Hyperlink")

        Dim rstfiltered As DAO.Recordset
        Dim Hyperlink As String

'Hyperlink wird übergeben. Wurde zusammengefasst zwecks Syntax
Hyperlink = strFileName & File_Name

' Tabelle öffnen, prüfen ob Hyperlink mit dem PDFs vorhanden
Set rstfiltered = CurrentDb.OpenRecordset("SELECT * FROM tbl_Hyperlink WHERE [Hyperlink] = '" & Hyperlink & "'")

'wenn vorhanden Infomeldung
If Not rstfiltered.EOF Then
  MsgBox "Es gibt bereits eine Datei mit dem gleichem Namen. " _
            & "Bitte den Namen mit einem Datum oder einer zusätzlichen Bezeichnung versehen.", vbOKOnly + vbExclamation, "Duplicate Entry"

            ' wenn nicht vorhanden hinzufügen der Variablen
        Else
   rstHyper.AddNew
   rstHyper!HyperName = Typ
   rstHyper!Hyperlink = strFileName & File_Name
   rstHyper!HyperKostenstellenIDRef = Forms![Formular1]![KostenstellenID]
   rstHyper.Update
End If

Set rstfiltered = Nothing

    ' Kann später weg genommen werden No need for this
     Forms![Formular1]![hyperhyper] = strFileName & File_Name
        Set FD = Nothing



End Function

复制文件并使用动态文件夹名创建超链接

寻求其他解决方法后进行编辑

1 个答案: