VBA批量调整本地图片

shenjianrong163 · 发表于 2021-1-2 15:09

本帖最后由 shenjianrong163 于 2021-1-2 18:01 编辑

VBA图像调整批量修改软件，利用Windows Image Acquisition (WIA)进行本地图片处理。本软件可打开多个图像，也可以打开文件夹，列出所有常见图片（jpg|jpge|bmp|png|gif|tif）文件及其尺寸大小，一次将所有图片修改成同样的尺寸大小、顺（逆）时针旋转、压缩，同时支持文件格式间的互换。程序用到山菊花版主的显示进度条和香川群子老师的递归遍历文件夹。本软件在Excel、Word和PowerPoint中皆可运行，有点遗憾的是PowerPoint不支持隐藏应用程序，如有哪位老师知晓处理方法，还请不吝赐教！

文件选择

设置大小及旋转角度

输出设置

使用介绍:
1.导入图片文件
既可以导入单个或多个图片，也可以导入某个文件夹，非常方便菜鸟级用户使用。在“1.文件”选项夹下，分别点击“添加文件”或“添加文件夹”（也可以通过按下对应的键盘按键）来导入某个图片或某些图片。对于选中的文件夹，支持对子文件夹的搜索，无论目录有多深，都能将图片整理出来，而且勾选上“测定图像分辨率”，可以查看出要更改的图片的大小，方便操作前后的对比。
2.修改图片大小及旋转
修改图片大小的方式分为：智能调整，通过计算图像的一边调整，用户自定义调整和指定原大小的百分比进行调整；旋转的角度分别为顺时针旋转90度、逆时针旋转90度、顺时针旋转180度。
3.处理后图片输出相关的相关设置
图片输出设置包括：输出目录，处理后的文件名（此处可以根据需要转换图片格式），JPEG压缩的压缩系数等修改。
4.调整日志
当设定完成之后，点击“调整”按钮即可按照前面所设置的参数进行图片调整，并显示调整日志及调整进度。

图像调整.rar (34.7 KB, 下载次数: 675)

shenjianrong163 · 发表于 2021-1-2 17:13

本帖最后由 shenjianrong163 于 2021-1-2 17:23 编辑

图片处理的核心代码：Private Sub ResizeIMG()
Const wiaFormatBMP = "{B96B3CAB-0728-11D3-9D7B-0000F81EF32E}"
Const wiaFormatPNG = "{B96B3CAF-0728-11D3-9D7B-0000F81EF32E}"
Const wiaFormatGIF = "{B96B3CB0-0728-11D3-9D7B-0000F81EF32E}"
Const wiaFormatJPG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
Const wiaFormatTIFF = "{B96B3CB1-0728-11D3-9D7B-0000F81EF32E}"
Dim Img 'As ImageFile
Dim IP1 'As ImageProcess
Dim IP2 'As ImageProcess
Dim IP3 'As ImageProcess
Dim IP4 'As ImageProcess
Dim FN As String, Path$, NewPath$, OutPutFile$, Extension$, d, i#, j%, s, t, k%
Dim nYs%, nRow#, nBl#, nCount%, tim
tim = Timer '获取当前时间
Randomize
nYs = Int(Rnd * 6 + 1) '随机一个颜色号
Me.Label4_1.ForeColor = Choose(nYs, 30720, 16711935, 16711680, 255, 32255, 16762880) '底层字体颜色
Set d = CreateObject("scripting.dictionary")
s = Array(".jpg", ".jpeg", ".png", ".bmp", ".gif", ".tif")
t = Array(wiaFormatJPEG, wiaFormatJPEG, wiaFormatPNG, wiaFormatBMP, wiaFormatGIF, wiaFormatTIFF)
For j = 0 To UBound(s)
      d(s(j)) = t(j)
Next
nRow = ListBox1.ListCount - 1
Cancel = True
取消.Enabled = True
With ListBox2
      .Clear
      .ColumnCount = 2
      .ColumnWidths = "60;290"
      .AddItem
      .List(0, 0) = "类型"
      .List(0, 1) = "消息"
End With
k = 0
For i = 1 To ListBox1.ListCount - 1
      If Cancel = False Then
         取消.Enabled = False
         With ListBox2
            .AddItem
            .List(i, 0) = "警告"
            .List(i, 1) = "用户终止调整!"
            '以下两句实现滚动条自动滚动
            .ListIndex = i
            .ListIndex = -1
         End With
         Exit Sub
      End If
      '=============================进度条开始
      nBl = i / nRow '进度百分比
      With Me
         Select Case nYs '进度条颜色
            Case 1
                  '绿色
                  .Label4_2.BackColor = RGB(200 * (1 - nBl), 233 - 113 * nBl, 200 * (1 - nBl))
            Case 2
                  '粉
                  .Label4_2.BackColor = RGB(245 - 80 * nBl, 210 * (1 - nBl), 245 - 80 * nBl)
            Case 3
                  '蓝色
                  .Label4_2.BackColor = RGB(210 * (1 - nBl), 225 - 170 * nBl, 245 - 125 * nBl)
            Case 4
                  '红色
                  .Label4_2.BackColor = RGB(255, 200 * (1 - nBl), 200 * (1 - nBl))
            Case 5
                  '棕色
                  .Label4_2.BackColor = RGB(250, 230 - 95 * nBl, 200 * (1 - nBl))
            Case 6
                  '青色
                  .Label4_2.BackColor = RGB(220 * (1 - nBl), 255 - 135 * nBl, 255 - 135 * nBl)
         End Select
         .Label4_2.Width = 310 * nBl '进度条长度(370是总长度，设计时有变请修改）
         .Label4_1.Caption = String(37, " ") & Format(nBl, "0%") '底层文字，前面的空格个数37根据实际修改
         .Label4_3.Caption = .Label4_1.Caption '顶层文字
         .Label4_3.Width = .Label4_2.Width '限制顶层文字显示宽度
      End With
      DoEvents '必须，否则进度条不显示过程
      '===============处理数据开始
      FN = Dir(ListBox1.List(i, 0)) '取得列表中的文件名
      Path = Left(ListBox1.List(i, 0), InStrRev(ListBox1.List(i, 0), "\")) '取得列表中文件的路径
      Set Img = CreateObject("WIA.ImageFile")
      Set IP1 = CreateObject("WIA.ImageProcess")
      Set IP2 = CreateObject("WIA.ImageProcess")
      Set IP3 = CreateObject("WIA.ImageProcess")
      Set IP4 = CreateObject("WIA.ImageProcess")
      Img.LoadFile ListBox1.List(i, 0)
      '“大小”设置-------------------------------------------
      If OptionButton1.Value = True Then '选中“智能图像调整”
         If Img.Width < Img.Height Then '图片的宽度小于高度
            IP1.Filters.Add IP1.FilterInfos("Scale").FilterID
            IP1.Filters(1).Properties("PreserveAspectRatio") = False '解除纵横比
            IP1.Filters(1).Properties("MaximumWidth") = Img.Width * TextBox1.Value / Img.Height '先等比例调整宽度
            IP1.Filters(1).Properties("MaximumHeight") = TextBox1.Value '再调整高度
            Set Img = IP1.Apply(Img)
            Set IP1 = Nothing
         Else '图片的宽度大于或等于高度
            IP1.Filters.Add IP1.FilterInfos("Scale").FilterID
            IP1.Filters(1).Properties("PreserveAspectRatio") = False '解除纵横比
            IP1.Filters(1).Properties("MaximumHeight") = Img.Height * TextBox1.Value / Img.Width '先等比例调整高度
            IP1.Filters(1).Properties("MaximumWidth") = TextBox1.Value '再调整宽度
            Set Img = IP1.Apply(Img)
            Set IP1 = Nothing
         End If
'          MsgBox TextBox1.Value
      ElseIf OptionButton2.Value = True Then  '选中“通过计算图像的一边调整”
         If ComboBox1.Value = "宽度" Then '下拉选中“宽度”
            IP1.Filters.Add IP1.FilterInfos("Scale").FilterID
            IP1.Filters(1).Properties("PreserveAspectRatio") = False '解除纵横比
            IP1.Filters(1).Properties("MaximumHeight") = Img.Height * TextBox2.Value / Img.Width '先等比例调整高度
            IP1.Filters(1).Properties("MaximumWidth") = TextBox2.Value '再调整宽度
            Set Img = IP1.Apply(Img)
            Set IP1 = Nothing
         Else '下拉选中“高度”
            IP1.Filters.Add IP1.FilterInfos("Scale").FilterID
            IP1.Filters(1).Properties("PreserveAspectRatio") = False '解除纵横比
            IP1.Filters(1).Properties("MaximumWidth") = Img.Width * TextBox2.Value / Img.Height '先等比例调整宽度
            IP1.Filters(1).Properties("MaximumHeight") = TextBox2.Value '再调整高度
            Set Img = IP1.Apply(Img)
            Set IP1 = Nothing
         End If
      ElseIf OptionButton3.Value = True Then '选中“用户自定义调整”
         IP1.Filters.Add IP1.FilterInfos("Scale").FilterID
         IP1.Filters(1).Properties("PreserveAspectRatio") = False '解除纵横比
         IP1.Filters(1).Properties("MaximumWidth") = TextBox3.Value '自定义宽度
         IP1.Filters(1).Properties("MaximumHeight") = TextBox4.Value '自定义高度
         Set Img = IP1.Apply(Img)
         Set IP1 = Nothing
      Else  '选中“指定原大小的百分比”
         IP1.Filters.Add IP1.FilterInfos("Scale").FilterID
         IP1.Filters(1).Properties("PreserveAspectRatio") = False '解除纵横比
         IP1.Filters(1).Properties("MaximumWidth") = Img.Width * Val(Label7.Caption) / 100 '指定原宽度的百分比
         IP1.Filters(1).Properties("MaximumHeight") = Img.Height * Val(Label7.Caption) / 100 '指定原高度的百分比
         Set Img = IP1.Apply(Img)
         Set IP1 = Nothing
      End If
      '“旋转”设置-------------------------------------------
      If CheckBox2.Value = True And CheckBox3.Value = True Then
         '旋转角度
         If OptionButton8.Value = True Then '顺时针旋转90度
            angle = 90
         ElseIf OptionButton9.Value = True Then '逆时针旋转90度
            angle = 270
         Else  '顺时针旋转180度
            angle = 180
         End If
         '旋转范围
         If OptionButton5.Value = True Then '全部旋转
            IP2.Filters.Add IP2.FilterInfos("RotateFlip").FilterID
            IP2.Filters(1).Properties("RotationAngle") = angle  '顺时针旋转90度。如果要实现逆时针旋转90度，则将数值改为270
            Set Img = IP2.Apply(Img)
            Set IP2 = Nothing
         ElseIf OptionButton6.Value = True Then '宽度大于高度旋转
            If Img.Width >= Img.Height Then
                  IP2.Filters.Add IP2.FilterInfos("RotateFlip").FilterID
                  IP2.Filters(1).Properties("RotationAngle") = angle  '顺时针旋转90度。如果要实现逆时针旋转90度，则将数值改为270
                  Set Img = IP2.Apply(Img)
                  Set IP2 = Nothing
            End If
         Else '宽度小于高度旋转
            If Img.Width < Img.Height Then
                  IP2.Filters.Add IP2.FilterInfos("RotateFlip").FilterID
                  IP2.Filters(1).Properties("RotationAngle") = angle  '顺时针旋转90度。如果要实现逆时针旋转90度，则将数值改为270
                  Set Img = IP2.Apply(Img)
                  Set IP2 = Nothing
            End If
         End If
      End If
      '“图像压缩”设置-------------------------------------------
      If CheckBox4.Value = True Then
         Extension = LCase(Right(FN, Len(FN) - InStrRev(FN, ".") + 1)) '取得文件的扩展名
         If OptionButton11.Value = True And OptionButton13.Value = True Then
            IP3.Filters.Add IP3.FilterInfos("Convert").FilterID
            IP3.Filters(1).Properties("FormatID").Value = d(ComboBox2.Value) '图片调整为选择框中的格式
            IP3.Filters(1).Properties("Quality").Value = 101 - Val(Label16.Caption)
            Set Img = IP3.Apply(Img)
            Set IP3 = Nothing
         Else
            IP3.Filters.Add IP3.FilterInfos("Convert").FilterID
            IP3.Filters(1).Properties("FormatID").Value = d(Extension)  '图片保留原格式
            IP3.Filters(1).Properties("Quality").Value = 101 - Val(Label16.Caption) '压缩质量
'             IP3.Filters(1).Properties("Compression").Value = ComboBox3.Value '取样方法
            Set Img = IP3.Apply(Img)
            Set IP3 = Nothing
         End If
      End If

'下接3楼

shenjianrong163 · 发表于 2021-1-2 17:23

'“输出”设置-------------------------------------------
If OptionButton11.Value = True Then '选中“保存调整后的图像到其他位置”
If Right(TextBox5.Value, 1) <> "" Then NewPath = TextBox5.Value & "" Else NewPath = TextBox5.Value
If OptionButton12.Value = True Then '选中“保留原文件名称”
If Dir(NewPath & FN) <> "" Then Kill NewPath & FN '删除重名图片
Img.SaveFile NewPath & FN
OutPutFile = NewPath & FN
Else '选中“生成递增文件名”
If Dir(NewPath & TextBox6.Text & Format(i - 1 + TextBox7.Value, Digit(ListBox1.ListCount - 1)) & TextBox8.Text & ComboBox2.Text) <> "" Then Kill NewPath & TextBox6.Text & Format(i - 1 + TextBox7.Value, Digit(ListBox1.ListCount - 1)) & TextBox8.Text & ComboBox2.Text '删除重名图片
Img.SaveFile NewPath & TextBox6.Text & Format(i - 1 + TextBox7.Value, Digit(ListBox1.ListCount - 1)) & TextBox8.Text & ComboBox2.Text
OutPutFile = NewPath & TextBox6.Text & Format(i - 1 + TextBox7.Value, Digit(ListBox1.ListCount - 1)) & TextBox8.Text & ComboBox2.Text
End If
Else '选中“调整后的图像覆盖原文件”
Kill ListBox1.List(i, 0) '删除原图
Img.SaveFile ListBox1.List(i, 0) '保存图片
OutPutFile = ListBox1.List(i, 0)
End If
Set Img = Nothing
With ListBox2 '输出调整信息
.AddItem
.List(i, 0) = "信息"
.List(i, 1) = "成功调整 " & OutPutFile
'以下自动调整ListBox2第二列的宽度
If (LenB(StrConv(ListBox2.List(i, 1), vbFromUnicode)) / 2 + 1) * ListBox2.Font.Size > k Then
k = (LenB(StrConv(ListBox2.List(i, 1), vbFromUnicode)) / 2 + 1) * ListBox2.Font.Size
If k > 290 Then ListBox2.ColumnWidths = "60;" & k
End If
'以下两句实现滚动条自动滚动
.ListIndex = i
.ListIndex = -1
End With
Next
If Cancel = True Then
取消.Enabled = False
With ListBox2
.AddItem
.List(i, 0) = "信息"
.List(i, 1) = "调整 " & .ListCount - 2 & "个文件 " & "用时" & Format(Timer - tim, "0.00") & "秒"
'以下两句实现滚动条自动滚动
.ListIndex = i
.ListIndex = -1
End With
End If
End Sub

复制代码

aecn · 发表于 2021-1-2 22:12

感谢楼主分享

lmgz007 · 发表于 2021-1-2 22:28

先留个足迹再学习

02761752696 · 发表于 2021-1-3 12:33

谢谢分享

浮生一梦... · 发表于 2021-1-3 14:48

学习了，谢谢分享！！！

libin890 · 发表于 2021-1-3 15:46

非常感谢楼主分享对于小白还是要学习

qlmgu · 发表于 2021-2-27 09:42

libin890 发表于 2021-1-3 15:46
非常感谢楼主分享对于小白还是要学习

谢谢分享，下载试用

xiaomils · 发表于 2021-4-6 10:28

楼主的几个分享都很好，感谢！

		自动登录	找回密码
密码			免费注册

[原创] VBA批量调整本地图片

评分

最新热点 /1