作者：绿色风
分类：
时间：2022-08-17
浏览：175
楼主
raulerini |
Q：在某个文件夹下有很多大小不等的图片，现在需要将这些大小不等的图片批量更改为同等大小的图片，应该如何操作？
A：可以利用VBA先导入图片，然后对图片的大小进行处理，最后再利用chartobject对象将图片导出。
- Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nindex As Long) As Long
- Private Const LOGPIXELSX = 88 '单位逻辑英寸像素
- Private Const LOGPIXELSY = 90
- Function PixX2PointX(mypoint) '借用阿木的磅和像素之间的转化
- PixX2PointX = Application.InchesToPoints(mypoint) / GetDeviceCaps(GetDC(0), LOGPIXELSX)
- End Function
- Function PIxY2PointY(mypoint)
- PIxY2PointY = Application.InchesToPoints(mypoint) / GetDeviceCaps(GetDC(0), LOGPIXELSY)
- End Function
- Sub 截取图片()
- mywidth = PixX2PointX(100)
- myheight = PIxY2PointY(100)
- Dim myPic As Shape
- Set myPic = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, mywidth, myheight)
- mypath = ThisWorkbook.Path & "\1\"
- myfilename = Dir(mypath & "*.jpg")
- Do While myfilename <> ""
- With myPic
- .Line.Visible = msoFalse
- .Fill.UserPicture mypath & myfilename
- End With
- With ActiveSheet.ChartObjects.Add(0, 0, myPic.Width, myPic.Height).Chart
- myPic.Copy
- .Paste
- .Export ThisWorkbook.Path & "\" & Replace(myfilename, ".jpg", "_new.jpg"), "JPG"
- .Parent.Delete
- End With
- myfilename = Dir
- Loop
- myPic.Delete
- Set myPic = Nothing
- Set rng = Nothing
- End Sub
 新建文件夹.rar
|
2楼
xyf2210 |
这个收藏 |
3楼
LOGO |
要是想在64位系统上使用此段代码应该如何修改呢？ |
免责声明
有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素，
经与ExcelTip.Net站长Apolloh商议并征得其同意，
现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示，
供有需要的人士查询使用，也慰缅曾经的论坛时代。
所示各个帖子的原作者如对版权有异议，
可与本人沟通提出，或于本站点留言，我们会尽快处理。
在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一