Excel-VBA-获取图片路径-插入文件夹中所有图片-获取图片名称-定义图片位置

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

''统一行高
'Dim nm As Integer
'For nm = 53 To 100 Step 1
'Rows(nm).RowHeight = 12.75
'Next

'第二方案，每个sheet 激活时发生时开始执行程序
'选择图片，自动插入图片，制作好报告

'获得打开的文件夹路径，若取消选择则显示对话框，终止程序
Dim dlgOpen As FileDialog
Dim MyPath As String
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
.Title = "请选择报告图片所在的 整体文件夹 By BergHOFF-Kane"
If .Show = -1 Then
MyPath = .SelectedItems(1)
Else
' MsgBox ("你未选择文件,可以编辑内容 By BergHOFF-Kane ")
End
End If
End With

'再次提醒是否开始自动插入图片
Dim a
a = MsgBox("请核对好产品报告类别！！是否开始自动插入图片", vbOKCancel + vbQuestion, "Kane 温馨提示")
If a = 2 Then
End
End If

Dim MyFile As String, i As Integer, j As Integer, k As Integer, arr() As String, Picleft As Integer

'以下，开始插入自动插入照片模块———————————————————————————————————————-----------------------————————————————————————0———
'图片位置,四张一行，图片高3.5cm,占8行，每行高0.44cm, 以下单位为磅，每磅0.035cm

Picleft = 98 '图片插入的开始位置

'MsgBox UBound(PicItem)

'========================================================================================================================================================

-------------------------------------------------------------------------------------------------1------------------------------------

On Error Resume Next '关闭错误提示

'换页，52开始 每页共62行 114, 176, 238,300 行
' If 62 - (Picleft - 52) Mod 62 < 10 Then
' Picleft = Picleft + (62 - (Picleft - 52) Mod 62) + 1
' End If

' Range(Cells(Picleft, 1), Cells(Picleft, 34)).Select '每部分的灰色分割,字体加粗
' With Selection.Interior
' .Pattern = xlSolid
' .PatternColorIndex = xlAutomatic
' .ThemeColor = xlThemeColorDark2
' .TintAndShade = 0
' .PatternTintAndShade = 0
' End With

' Picleft = Picleft + 2

i = 0 '图片张数

---------------------------------------------------------------------------------------3------------------------------------------------------------------------------

MyFile = Dir(MyPath & "\" & "*.jpg") '将jpg结尾的所有文件打开，但是在这里只打开第一个符合的文件，接下来的文件在do循环里依次打开 '查询所选文件夹中的所有文件
'MsgBox Dir(MyPath & "\" & "*.JPG") 'JPG是图片文件扩展名，必要时可以修改

Do While MyFile <> "" 'Dir会打开空文件，需要这个 语句过滤掉

空文件

'换页，52开始 每页共62行 114, 176, 238,300 行
' If 62 - (Picleft - 52) Mod 62 < 8 Then
' Picleft = Picleft + (62 - (Picleft - 52) Mod 62) + 2
' ElseIf (Picleft - 52) Mod 62 = 1 Then
' Picleft = Picleft + 1
' End If

i = i + 1
ReDim Preserve arr(i)
arr(i) = MyFile
MyFile = Dir '之前dir()下已经打开了多个文件，若第二次调用 Dir 函数，但不带任何参数，则函数将返回同一目录下的下一个 *.ini 文件

ActiveSheet.Pictures.Insert(MyPath & "\" & PicItem(j) & "\" & arr(i)).Select '插入各个图片
With Selection.ShapeRange '定义插入图片的位置
'图片位置,四张一行，图片高3.5cm,占8行，每行高0.44cm, 以下单位为磅，每磅0.035cm
'插入一行Selection.Insert Shift:=xlDown
.Left = Cells(Picleft, 1).Left
.Top = Cells(Picleft, 1).Top
.Height = 96 '报告中图片固定高度3.5mm，高3.0此处应改为85.7
.IncrementLeft ((i - 1) Mod 4) * 132 '图片左边的距离，高3.0此处应改为128

If j = 1 Then '插入外箱尺寸和总重
Cells(Picleft - 1, ((i - 1) Mod 4) * 9 + 1) = Left(arr(i), Len(arr(i)) - 4)
' McSize = McSize & " x " & Left(arr(i), Len(arr(i)) - 4)
' Cells(56, 12) = "见下图"
' Cells(56, 20) = "见下图"

' ElseIf j > 4 And j <> 9 Then '尺寸和重量，需要多一行 插入图片名
Cells(Picleft - 1, ((i - 1) Mod 4) * 9 + 1) = Left(arr(i), Len(arr(i)) - 4) '1,9,17,33获得每个图片的名称
' End If

If .Height > .Width Then '需要旋转的图片转90度, 但是位置不对齐，需要继续完善下列代码
.IncrementRotation 90#
.Width = 99.2125984252
.Left = Cells(Picleft, 1).Left
.IncrementLeft ((i - 1) Mod 4) * 132 '权宜
.IncrementTop -13.5 ' 权宜
End If

'Selection.ShapeRange.Align msoAlignTops, msoFalse '上对齐
'Selection.ShapeRange.Distribute msoDistributeHorizontally, msoFalse '水平分布
End With

If i Mod 4 = 0 Then '确保一行4张图片后，换行
Picleft = Picleft + 9
End If
Loop


停顿
b = MsgBox("Hold，是否继续！！// " & "已经完成" & PicItem(j) & " //插入位置是" & Picleft, vbOKCancel + vbQuestion, "Kane 温馨提示")
If b = 2 Then
End
End If

----------------------------------------------------------------------------------------------------------1--------------------------------------------------