|
楼主 |
发表于 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楼
|
|