Can we attach multiple images to a useform in VBA, save in a folder with a specific naming convention and retrieve later using that name?

Question

I have a VBA project where I need to create a userform on which there should be an attachment button to select multiple images and save them in a folder with a specific name. Later, if a person looks up that name from the search box, it should call all the information saved along with the images. The names should be as follows Sh-0001-01 (where 0001 represents invoice number and 01 denotes attachment number).

I have got a file from another forum that can load images into the image box and scroll across them but there is no mechanism to add new images except copying new images to the back-end folder. And also, no functionality to save attachments with a specific name and look them up using that name.

The outcome is attached as an image. The example code file can be accessed via this link: https://drive.google.com/file/d/1HXLjDIpjNmgxLxegYiexxEykh4f_54sY/view?usp=sharing

As it was mandatory by Stackoverflow to include a sample code, here is part of the code that is in the file in the drive:

Public Const fPath As String = "C:\Test\"
Sub LaunchForm()
UserForm1.Show
End Sub

Function PhotoNum(numx As Integer) As String
Dim PhotoNames As String, iFile As String
Dim i As Integer
Dim ArrayPhoto() As Variant
iFile = "*.*"
PhotoNames = Dir(fPath & iFile) 
i = 0
Do Until PhotoNames = ""
i = i + 1
ReDim Preserve ArrayPhoto(1 To i)
ArrayPhoto(i) = PhotoNames
PhotoNames = Dir
Loop
PhotoNum = ArrayPhoto(numx)

End Function

Function MaxPhoto() As Integer
Dim PhotoNames As String, iFile As String
Dim i As Integer
Dim ArrayPhoto() As Variant 
iFile = "*.*"
PhotoNames = Dir(fPath & iFile)
i = 0
Do Until PhotoNames = ""
i = i + 1
ReDim Preserve ArrayPhoto(1 To i)
ArrayPhoto(i) = PhotoNames
PhotoNames = Dir
Loop

MaxPhoto = UBound(ArrayPhoto)

End Function

Any help is appreciated.

Answer 1

Please, try the next way. A text box named "tbOrder" must exist. In it the order/invoice number must be entered (manually or by code). The rest of controls are the one used in your sent testing workbook. Please, copy the next code in the form code module. Only a sub showing the form should exist in a standard module. A new button (btAttach) to add attachment has been added and a check box (chkManyAtt) where to specify the multiple selection option:

Option Explicit

Private Const fPath As String = "C:\test\"
Private photoNo As Long, arrPhoto() As Variant, boolNoEvents As Boolean, prevVal As Long, boolFound As Boolean
Private boolManyAttch As Boolean

Private Sub btAttach_Click()
    If Len(tbOrder.Text) <> 7 Then MsgBox "An invoice number is mandatory in its specific text box (7 digits long)": Exit Sub
    Dim noPhotos As Long, runFunc As String
    
    runFunc = bringPicture(Left(tbOrder.Text, 7), True)
    If Not boolFound Then noPhotos = -1
    
    Dim sourceFile As String, destFile As String, attName As String, strExt As String, i As Long
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Please, select the picture to be added as attachment for invoice " & Me.tbOrder.Text & " (" & photoNo & ")"
        .AllowMultiSelect = IIf(boolManyAttch = True, True, False)
        .Filters.Add "Picture Files", "*.jpg", 1
        If .Show = -1 Then
                For i = 1 To .SelectedItems.Count
                    sourceFile = .SelectedItems(i): 'Stop
                    attName = Me.tbOrder.Text & "-" & Format(IIf(noPhotos = -1, 1, photoNo + 1), "00")
                    strExt = "." & Split(sourceFile, ".")(UBound(Split(sourceFile, ".")))
                    destFile = fPath & attName & strExt
                    FileCopy sourceFile, destFile
                    ReDim Preserve arrPhoto(IIf(noPhotos = -1, 0, UBound(arrPhoto) + 1)): noPhotos = 0
                    arrPhoto(UBound(arrPhoto)) = attName & strExt
                    photoNo = photoNo + 1
                Next i
        Else
            Exit Sub
        End If
    End With
    Me.TextBox2.Text = photoNo: Me.TextBox2.Enabled = False
    Me.TextBox1.Text = photoNo
End Sub

Private Sub chkManyAtt_Click()
    If Me.chkManyAtt.Value Then
        boolManyAttch = True
    Else
        boolManyAttch = False
    End If
End Sub

Private Sub CommandButton1_Click() 'Prev button
 Dim currPic As Long

 currPic = Me.TextBox1.Value

 If currPic > 1 Then
    Me.Image1.Picture = LoadPicture(fPath & arrPhoto(currPic - 2))
    boolNoEvents = True                'stop the events when TextBox1 is changed
     Me.TextBox1.Text = currPic - 1
     prevVal = Me.TextBox1.Value
    boolNoEvents = False              'restart events
 End If
End Sub
Private Sub CommandButton2_Click() 'Next button
 Dim currPic As Long

    currPic = Me.TextBox1.Value

 If currPic < photoNo Then
    Me.Image1.Picture = LoadPicture(fPath & arrPhoto(currPic))
    boolNoEvents = True
      Me.TextBox1.Text = currPic + 1
      prevVal = Me.TextBox1.Value
    boolNoEvents = False
  Else
    MsgBox "Please, select a valid image number..."
 End If
End Sub

Private Sub tbOrder_Change() 'the textbox where to input the order/invoice nubmer
    Dim firstPict As String
    If Len(tbOrder.Text) >= 7 Then
       photoNo = 0: Erase arrPhoto   'clear the variable keeping the number of found photos and the array keeping them
       firstPict = bringPicture(Left(tbOrder.Text, 7)) 'to make it working even if you paste "Sh-0002-20"
       If firstPict <> "" Then 'determining the first picture to be placed
            With Me.Image1
                .Picture = LoadPicture(fPath & firstPict)
                .PictureSizeMode = fmPictureSizeModeZoom
            End With
            boolNoEvents = True      'avoiding the event to be triggeret twice
                Me.TextBox1.Text = 1
                
                With Me.TextBox2
                    .Enabled = True
                    .Text = photoNo
                    .Enabled = False
                End With
            boolNoEvents = False
        Else
            Me.Image1.Picture = LoadPicture(vbNullString) 'clear the picture if no order/invoice have been written in the text box
            Me.TextBox2.Text = "": Me.TextBox1.Text = ""
       End If
    End If
End Sub

Function bringPicture(strName As String, Optional boolAttach As Boolean = False) As String
   Dim PhotoNames As String, arrPh, noPict As Long, firstPict As String, ph As Long
   PhotoNames = Dir(fPath & strName & "*.*") 'find the first photo with the necessary pattern name

   If boolAttach Then
        ReDim arrPhoto(0): photoNo = 0
   Else
        ReDim arrPhoto(photoNo)   'firstly ReDim the array
   End If
   boolFound = False
   Do While PhotoNames <> ""
        boolFound = True
        arrPhoto(photoNo) = PhotoNames: photoNo = photoNo + 1
        ReDim Preserve arrPhoto(photoNo)
        PhotoNames = Dir()
   Loop
   If photoNo > 0 Then
        ReDim Preserve arrPhoto(photoNo - 1) 'eliminate the last empty array element
        bringPicture = arrPhoto(0)                 'return the first photo in the array
  End If
  
End Function

Private Sub TextBox1_Change()                     'manually change the picture number
    If Not boolNoEvents Then                        'to not be treggered when changed by code
        If IsNumeric(Me.TextBox1.Value) Then   'to allow only numbers
            If Len(Me.TextBox1.Value) >= Len(CStr(photoNo)) Then 'to allow numbers less or equal with the maximum available
                If CLng(TextBox1.Text) > photoNo Then
                      MsgBox "Select valid image number"
                      boolNoEvents = True
                        Me.TextBox1.Text = prevVal
                      boolNoEvents = False
                Else
                    Me.Image1.Picture = LoadPicture(fPath & arrPhoto(Me.TextBox1.Value - 1))
                    Me.Image1.PictureSizeMode = fmPictureSizeModeZoom
                End If
                prevVal = Me.TextBox1.Value
            End If
        Else
            Me.TextBox1.Text = ""
        End If
    End If
End Sub

If something not clear enough, please do not hesitate to ask for clarifications.