Speicherort von erstelltem PDF verbessern (Access)

Sternschnuppe @, Samstag, 24.11.2018, 20:16 (vor 19 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

gesamter Thread:

 RSS-Feed dieser Diskussion

powered by my little forum