Speicherort von erstelltem PDF verbessern (Access)

Sternschnuppe @, Samstag, 24.11.2018, 20:09 (vor 15 Tagen)

Hallo zusammen,
ich arbeite an einer Access2010-Datenbank.
Per Button im Formular erzeuge ich aus einem Bericht ein PDF-Dokument, welches automatisch unter dem gefilterten Datensatz in einem Anlagefeld abgespeichert wird. Dieses funktioniert auch gut.
Problem:
Gleichzeitig wird diese PDF-Datei auch an den zuletzt gespeicherten Ort hinterlegt. Dieses darf aus Datenschutzgründen nicht.

Kann mir jemand sagen bzw. helfen, wie ich mein Modul verändern muss, um nur in der aktuellen Datenbank das PDF zu speichern?
Über Rückmeldungen und Hilfestellungen freue ich mich sehr :-)


Modul1:

Option Compare Database
Option Explicit

Function GetNamePath()
     Dim MyDB As Database

     Set MyDB = CurrentDb()
     GetNamePath = MyDB.Name
 End Function


Private Sub cmdDeckblattNeu_Click()
Dim BerichtsName As String
Dim sPfad   As String
Dim fileName As String
Dim Filter As String
Dim sAnlage As String
Dim criteria As String
     
'Info über Speicherort, Berichtsname, Speichername, Filteroption (persoID)
BerichtsName = "Deckblatt"
sPfad = GetNamePath()
sAnlage = Format$(Now, "yyyy-mm-dd_hh.mm") & " " & BerichtsName & " - " & Me!persoNameAnzeigenNachVor & ".pdf"
Filter = "persoID = " & Me![persoID]

'Bericht wird in der Handakte der Person gespeichert
DoCmd.OpenReport BerichtsName, acPreview, , Filter
DoCmd.OutputTo acOutputReport, "Deckblatt", acFormatPDF, sAnlage, , , , acExportQualityScreen
Call StoreBLOB(sAnlage, sPfad, "tblPersonen", "persoHandakte", True, "persoID", Me!persoID)
DoCmd.Close acReport, BerichtsName, acSaveNo

Modul2:

Function StoreBLOB(strFilename As String, strACCDB As String, strTable As String, _
                             strFieldAttach As String, Optional boolEdit As Boolean, _
                           Optional strIDField As String, Optional varID As Variant, _
                                          Optional strAttachment As String) As Boolean
    Dim fld2 As DAO.Field2
    Dim rstDAO As DAO.Recordset2
    Dim rstACCDB As DAO.Recordset2
    Dim MyDB As Database
    On Error GoTo ErrHandler
    Set MyDB = OpenDatabase(strACCDB)
    Set rstDAO = MyDB.OpenRecordset("SELECT * FROM [" & strTable & "]", _
                                                                        dbOpenDynaset)
    If boolEdit Then
        If IsNull(varID) Then Err.Raise vbObjectError + 1, , _
                                                       "Keine Datensatz-ID angegeben!"
        rstDAO.FindFirst "CStr([" & strIDField & "])='" & CStr(varID) & "'"
        If rstDAO.NoMatch Then Err.Raise vbObjectError + 2, , _
                                      "Datensatz mit ID " & varID & " nicht gefunden!"
        rstDAO.Edit
    Else
        rstDAO.AddNew
    End If
    Set rstACCDB = rstDAO(strFieldAttach).Value
    If boolEdit Then
        If rstACCDB.EOF Then 'Fall 1: Es gibt noch keine Anlagen; > neue Anlage
            rstACCDB.AddNew
        Else
            Do While Not rstACCDB.EOF
                rstACCDB.MoveNext
            Loop
            rstACCDB.FindFirst "[FileName]='" & strAttachment & "'"
            'Fall2: Es gibt keine Anlage mit dem Namen in sAttachment: > neue Anlage
            'Fall3: Anlage gefunden; dann editieren
                If rstACCDB.NoMatch Then
                    rstACCDB.AddNew
                Else
                    rstACCDB.Edit
                End If
        End If
    Else                'Dateien per VBA in Anlage-Felder importieren und exportieren
        rstACCDB.AddNew
    End If

... Code geht noch weiter ...

Speicherort von erstelltem PDF verbessern

Sternschnuppe @, Samstag, 24.11.2018, 20:16 (vor 15 Tagen) @ Sternschnuppe

... Weiteren Code...

Set fld2 = rstACCDB.Fields!FileData
    On Error Resume Next
    fld2.LoadFromFile (strFilename)

    If Err.Number = -2146697202 Then    'Unerlaubte Dateiendung! Spezialbehandlung...
        On Error GoTo ErrHandler
        Name strFilename As strFilename & ".dat"  'Datei mit Endung ".dat" anfügen
        fld2.LoadFromFile (strFilename & ".dat")  'Datei laden
        Name strFilename & ".dat" As strFilename  'Umbenennung rückgängig machen
        'Anlagename setzen
        rstACCDB.Fields!fileName = Mid(strFilename, InStrRev(strFilename, "\") + 1)
        rstACCDB.Update
    Else
        On Error GoTo ErrHandler
        rstACCDB.Update
    End If


Ende:
    rstDAO.Update
    StoreBLOB = True    'Rückgabe True = Alles ok.

Finally:
    On Error Resume Next
    rstACCDB.Close
    rstDAO.Close
    Set rstACCDB = Nothing
    Set rstDAO = Nothing
    Set fld2 = Nothing
    Exit Function
ErrHandler:
    MsgBox Err.Description, vbCritical
    Resume Finally
End Function

Function RestoreBLOB(strACCDB As String, strTable As String, strFieldAttach As _
    String, strIDField As String, varID As Variant, strFilename As String, Optional _
    strAttachment As String = "*") As Boolean
    Dim rstDAO As DAO.Recordset
    Dim rstACCDB As DAO.Recordset2
    Dim MyDB As Database
    On Error GoTo ErrHandler
    Set MyDB = OpenDatabase(strACCDB)

    Set rstACCDB = MyDB.OpenRecordset("SELECT [" & strFieldAttach & _
        "].FileData FROM " & strTable & " WHERE [" & strIDField & "]=" & varID & _
        " AND [" & strFieldAttach & "].FileName LIKE '" & strAttachment & "'", _
        dbOpenSnapshot)

    If rstACCDB.EOF Then
        Err.Raise vbObjectError + 3, "RestoreBLOB", "Das Anlagefeld ist leer"
    End If
    If Dir(strFilename) <> "" Then
        Kill strFilename
        DoEvents
    End If
    On Error Resume Next    'Fehlerbehandlung ausschalten, da nachfolgende Zeile
                            'Fehler bei blockierten Dateiendungen erzeugt
    rstACCDB(0).SaveToFile strFilename
    If Err.Number = (-2146697202) Then
        'Spezialbehandlung:
        'Datei wird mit Endung .dat versehen, was erlaubte Endung ist
        'Anschließend wird wiederhergestellte Datei wieder korrekt umbenannt
        rstACCDB(0).SaveToFile strFilename & ".dat"
        DoEvents
        Name strFilename & ".dat" As strFilename
    End If
    RestoreBLOB = True
Finally:
    On Error Resume Next
    Set rstACCDB = Nothing
    rstDAO.Close
    Set rstDAO = Nothing
    Exit Function
ErrHandler:
    MsgBox Err.Number & "/" & Err.Description, vbCritical
    Resume Finally
End Function

Function DeleteBLOB(strACCDB As String, strTable As String, _
                    strFieldAttach As String, Optional strIDField As String, Optional varID As Variant, _
                                          Optional strAttachment As String) As Boolean
    'Dim fld2 As DAO.Field2
    Dim rstDAO As DAO.Recordset2
    Dim rstACCDB As DAO.Recordset2
    Dim MyDB As Database
    On Error GoTo ErrHandler
    Set MyDB = OpenDatabase(strACCDB)
    Set rstDAO = MyDB.OpenRecordset("SELECT * FROM [" & strTable & "]", _
                                                                        dbOpenDynaset)
        If IsNull(varID) Then Err.Raise vbObjectError + 1, , _
                                                       "Keine Datensatz-ID angegeben!"
        rstDAO.FindFirst "CStr([" & strIDField & "])='" & CStr(varID) & "'"
        If rstDAO.NoMatch Then

                Err.Raise vbObjectError + 2, , "Datensatz mit ID " & varID & " nicht gefunden!"
                GoTo Finally
        Else
            rstDAO.Edit
        End If
    Set rstACCDB = rstDAO(strFieldAttach).Value

            Do While Not rstACCDB.EOF
                Debug.Print rstACCDB.fileName
                rstACCDB.MoveNext
            Loop
            rstACCDB.FindFirst "[FileName]='" & strAttachment & "'"

                If rstACCDB.NoMatch Then
                   MsgBox "Die Datei-Anlage konnte nicht gefunden werden."
                Else
                   rstACCDB.Delete
                End If

    rstDAO.Update
    DeleteBLOB = True    'Rückgabe True = Alles ok.

Finally:
    On Error Resume Next
    rstACCDB.Close
    rstDAO.Close
    Set rstACCDB = Nothing
    Set rstDAO = Nothing
    'Set fld2 = Nothing
    Exit Function
ErrHandler:
    MsgBox Err.Description, vbCritical
    Resume Finally
End Function

Speicherort von erstelltem PDF verbessern

Martin Asal @, Montag, 26.11.2018, 14:49 (vor 13 Tagen) @ Sternschnuppe

Uff, sorry, aber wenn du mit Name und Kill arbeiten kannst, wirst du bestimmt auch herausfinden, wo genau der Fehler liegt. Wird wohl an irgendeiner Verzweigung oder Schleife liegen. Aber das Forum ist dafür da, Menschen zu helfen, denen Wissen fehlt. Du dagegen hast das Wissen, aber scheinst keine Lust auf das notwendige Debugging zu haben...

Martin

RSS-Feed dieser Diskussion
powered by my little forum