我们能否将多个图像附加到 VBA 中的一个 useform，保存在具有特定命名约定的文件夹中，稍后使用该名称检索？
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?
我有一个 VBA 项目，我需要在其中创建一个用户表单，在该用户表单上应该有一个 select 多个图像的附件按钮，并将它们保存在具有特定名称的文件夹中。稍后，如果有人从搜索框中查找该名称，它应该调用与图像一起保存的所有信息。名称应如下所示 Sh-0001-01（其中 0001 表示发票编号，01 表示附件编号）。
我从另一个论坛得到了一个文件，它可以将图像加载到图像框中并滚动浏览它们，但是除了将新图像复制到后端文件夹之外，没有添加新图像的机制。而且，没有使用特定名称保存附件并使用该名称查找附件的功能。
结果以图片形式附上。可以通过此 link 访问示例代码文件：
https://drive.google.com/file/d/1HXLjDIpjNmgxLxegYiexxEykh4f_54sY/view?usp=sharing
由于 Whosebug 强制包含示例代码，以下是驱动器文件中的部分代码：
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
感谢任何帮助。
请尝试下一种方法。必须存在名为“tbOrder”的文本框。其中必须输入 order/invoice 数字（手动或通过代码）。其余控件是您发送的测试工作簿中使用的控件。请复制表单代码模块中的下一个代码。标准模块中只应存在显示表单的子项。添加了用于添加附件的新按钮 (btAttach) 和用于指定多选选项的复选框 (chkManyAtt)：
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
如果有什么地方不够清楚，请不要犹豫，要求澄清。
我有一个 VBA 项目，我需要在其中创建一个用户表单，在该用户表单上应该有一个 select 多个图像的附件按钮，并将它们保存在具有特定名称的文件夹中。稍后，如果有人从搜索框中查找该名称，它应该调用与图像一起保存的所有信息。名称应如下所示 Sh-0001-01（其中 0001 表示发票编号，01 表示附件编号）。
我从另一个论坛得到了一个文件，它可以将图像加载到图像框中并滚动浏览它们，但是除了将新图像复制到后端文件夹之外，没有添加新图像的机制。而且，没有使用特定名称保存附件并使用该名称查找附件的功能。
结果以图片形式附上。可以通过此 link 访问示例代码文件： https://drive.google.com/file/d/1HXLjDIpjNmgxLxegYiexxEykh4f_54sY/view?usp=sharing
由于 Whosebug 强制包含示例代码，以下是驱动器文件中的部分代码：
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
感谢任何帮助。
请尝试下一种方法。必须存在名为“tbOrder”的文本框。其中必须输入 order/invoice 数字（手动或通过代码）。其余控件是您发送的测试工作簿中使用的控件。请复制表单代码模块中的下一个代码。标准模块中只应存在显示表单的子项。添加了用于添加附件的新按钮 (btAttach) 和用于指定多选选项的复选框 (chkManyAtt)：
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
如果有什么地方不够清楚，请不要犹豫，要求澄清。