Solved Access vba Manage an Attachment field with vba

[Papashep]

Hi
I am trying to check if an attachment exists on a recordset2 record and if it does remove the field contents and then add a new attachment to the same record so I Only have the one attachment entry on the record. My code is giving me two problems:
1. The If statement If .Fields("Logo").Type = dbAttachment And Not IsNull(!Logo.value) This is failing in that currently the Logo field does not contain an attachment and within that code block, I then get my next problem
2. The statement .Fields("Logo").value.Attachments.Delete fails with the error code 438 Object doesn't support this property or method.

Can anyone help please, this is the first time I have tried to manage any attachments.

I am using Access 365 64bit on a WIndows 11 PC

Below is the function that I am calling

Public Function GetLogo(CompID As Integer) As String
    On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim rst As DAO.Recordset2
    Dim fDialog As FileDialog
    Dim sFilePath As String

    Set db = CurrentDb
    Set rst = db.OpenRecordset("SELECT * FROM Company WHERE Company.CompanyID =" & CompID)

    ' Set up the File Dialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

    With fDialog
        .Title = "Please select a Logo file"
        .Filters.Clear
        .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"

        ' Show the dialog and get the file path
        If .Show = -1 Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "You clicked Cancel in the file dialog box."
            Exit Function
        End If
    End With

    With rst
        If Not .EOF Then
            ' Check if the Logo field contains attachments
            If .Fields("Logo").Type = dbAttachment And Not IsNull(!Logo.value) Then
                ' Clear existing attachments
                .Edit
                .Fields("Logo").value.Attachments.Delete
                .Update
            End If

            ' Add the new attachment
            .Edit
            .Fields("Logo").value.Attachments.Add sFilePath
            .Update
        Else
            MsgBox "No record found for CompanyID " & CompID
        End If
    End With

    Exit Function

ErrHandler:
    MsgBox "Error Line: " & Erl & " Error number " & Err.Number & ": " & Err.Description
    Resume Next
End Function

 

[Pat Hartman]

If you only need a single logo per company, use the OLE Object data type rather than the Attachment.

 

[Papashep]

Hi Pat

Thanks for your response, but what I want to know is how to manage attachment fields

Kind Regards Melvyn

 

[arnelgp]

Public Function GetLogo(CompID As Integer) As String
    On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim rst As DAO.Recordset2
    Dim fDialog As FileDialog
    Dim sFilePath As String

    Set db = CurrentDb
    Set rst = db.OpenRecordset("SELECT * FROM Company WHERE Company.CompanyID =" & CompID, dbOpenDynaset)

    ' Set up the File Dialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

    With fDialog
        .Title = "Please select a Logo file"
        .Filters.Clear
        .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"

        ' Show the dialog and get the file path
        If .Show = -1 Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "You clicked Cancel in the file dialog box."
            Exit Function
        End If
    End With

    If Not (rst.BOF And rst.EOF) Then
        rst.MoveFirst
        rst.Edit
        
        With .Fields("Logo").Value
        
            If Not .EOF Then
                'replace the attachment
                .Edit
                .Fields("FileData").LoadFromFile sFilePath
                .Update
            
            Else
                MsgBox "No record found for CompanyID " & CompID
            End If
        
        End With
        
        rst.Update
    End If
    rst.Close

ExitFunc:
    Set rst = Nothing
    Set db = Nothing
    Exit Function

ErrHandler:
    MsgBox "Error Line: " & Erl & " Error number " & Err.Number & ": " & Err.Description
    Resume ExitFunc
End Function

 

[Papashep]

Public Function GetLogo(CompID As Integer) As String
    On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim rst As DAO.Recordset2
    Dim fDialog As FileDialog
    Dim sFilePath As String

    Set db = CurrentDb
    Set rst = db.OpenRecordset("SELECT * FROM Company WHERE Company.CompanyID =" & CompID, dbOpenDynaset)

    ' Set up the File Dialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

    With fDialog
        .Title = "Please select a Logo file"
        .Filters.Clear
        .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"

        ' Show the dialog and get the file path
        If .Show = -1 Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "You clicked Cancel in the file dialog box."
            Exit Function
        End If
    End With

    If Not (rst.BOF And rst.EOF) Then
        rst.MoveFirst
        rst.Edit
       
        With .Fields("Logo").Value
       
            If Not .EOF Then
                'replace the attachment
                .Edit
                .Fields("FileData").LoadFromFile sFilePath
                .Update
           
            Else
                MsgBox "No record found for CompanyID " & CompID
            End If
       
        End With
       
        rst.Update
    End If
    rst.Close

ExitFunc:
    Set rst = Nothing
    Set db = Nothing
    Exit Function

ErrHandler:
    MsgBox "Error Line: " & Erl & " Error number " & Err.Number & ": " & Err.Description
    Resume ExitFunc
End Function

Hi thanks for your help. I tried your code, but it gave me the error Invalid or unqualified reference on the line: With .Fields("Logo").Value
I have now found the solution which I will post in my reply.

 

[Papashep]

Have now found the solution which I have shown in the code below.
The objective of the code was to find a new Logo image which I save as an attachment on my company record. I also wanted to ensure that only one image is stored in my Logo attachment field.
I have changed it from a Function to a SSub routine in my code.
I have tested the code to clear out multiple images in the attachment field and add only the select file, leaving me with just one attachment image.

Sub AddCompanyLogo(ByVal CompID As Integer)
' ----------------------------------------------------------------
' Procedure Name: AddCompanyLogo
' Purpose: Add new Attachment, Only allows one attachment per Company record and removes any previousl created attachments
' Procedure Kind: Sub
' Procedure Access: Private
' Parameter CompID (Integer): The Company ID
' Author: Melvyn
' Date: 28/02/2024
' ----------------------------------------------------------------
   
    On Error GoTo ErrHandler

    Dim db As DAO.Database
    Dim rsMainRecords As DAO.Recordset2
    Dim rsAttachments As DAO.Recordset2
    Dim fDialog As FileDialog
    Dim sFilePath As String
    Dim fld As DAO.Field2
    Dim RecordCount As Integer

    Set db = CurrentDb
   
    ' Set up the File Dialog
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

    With fDialog
        .Title = "Please select a Logo file"
        .Filters.Clear
        .Filters.Add "Image Files", "*.jpg; *.jpeg; *.png; *.bmp; *.gif"

        ' Show the dialog and get the file path
        If .Show = -1 Then
            sFilePath = .SelectedItems(1)
        Else
            MsgBox "You clicked Cancel in the file dialog box."
            Exit Sub
        End If
    End With
   
    Set rsMainRecords = db.OpenRecordset("SELECT * FROM Company WHERE Company.CompanyID =" & CompID, dbOpenDynaset)
    Set fld = rsMainRecords("Logo")
   
    'Get the attachment field
   
    Do Until RecordCount = 1
   
        Set rsAttachments = fld.value
       
        rsMainRecords.Edit
               
        'Remove all attachments
        Do Until rsAttachments.EOF
       
            rsAttachments.Delete
           
            rsAttachments.MoveNext
           
        Loop
           
        'Add new attchment
        rsAttachments.AddNew
        rsAttachments("FileData").LoadFromFile sFilePath
        rsAttachments.Update
       
        rsMainRecords.Update
       
        RecordCount = 1
   
    Loop

    rsMainRecords.Close
    db.Close
   
   
    Set rsMainRecords = Nothing
    Set rsAttachments = Nothing
    Set db = Nothing
   
    Exit Sub

ErrHandler:
    MsgBox "Error Line: " & Erl & " Error number " & Err.Number & ": " & Err.Description
    Resume Next
   
End Sub

 

[Pat Hartman]

I also wanted to ensure that only one image is stored in my Logo attachment field.

All the more reason for not using the Attachment data type.

 

[Papashep]

Hi Pat

Sorry, but I disagree with you

 

[Pat Hartman]

Whatever.