国庆惊喜大促狂欢大放价
23门原创教程，原价168，限时87元！！
国庆狂欢，优惠不等人，早买早便宜
点击了解
支持微信公众号+小程序+APP+PC网站多平台学习
“听说公司新来个漂亮的妹纸好像叫雨夜，她很喜欢Excel，也特别爱学习，要不要把她拉到你的团队里培养一下？”土豆哥对着企鹅妹说道。
“先考验一下再说吧！”企鹅妹面无表情的说着
领导罗：“雨夜，你把这个Excel文件里的图片按照原尺寸(有些图片已经变形了)弄到电脑里，后天上班要交给我！”。
雨夜打开文件一看，脸上露出了难过的表情，不是因为图片已经变形了，而是这图片也太多了点吧，2555个，为什么不是555个呢，最起码还能大声的55555一场。
看一下数据情况图：
真是越看越想哭，这么多，得弄到啥时候啊？
“我说，这事儿是你安排的吧？”远处的土豆哥对着企鹅妹说。
“我像那么无聊又多事儿的人吗？”说完企鹅妹就往雨夜的方向走了过去，看到雨夜那难过的表情，关切的问道：“遇到什么难题了，让我看看能帮你吗？”
“喏“，雨夜有气无力的用手指了指领导罗给她的文件，小声的说着：“2555个图片，真不知道是那个BT弄出来的，这要导出来得搞到什么时候啊！”
企鹅妹听着，心想：“真是个好领导啊！”，然后眉头一紧说：“嗯，看起来还是有迹可寻的，要不你先起来，让我试试？”
雨夜起身，把位置让给了企鹅妹，只见企鹅妹在键盘上 啪啪啪 的敲了起来，大概10分钟后，企鹅妹手停了，背靠在椅子上，闭着眼睛流露出微笑的表表情，轻轻的点着头，像是在想什么又像是在休息一般！几分钟后屏幕上弹出个提示框！
雨夜一看，惊讶的说：“这是什么意思？”
企鹅妹睁开眼睛，打开保存的文件夹，看了一下文件数量，嗯，数量是对的，应该是完成了。
雨夜问：“企鹅姐姐，您是怎么做到的，才10多分钟就搞定了？能教教我吗？”
企鹅妹说：这是用vba写的程序，代码在这里，里面都有注释(解释)，代码在这儿！
代码
'注意得是，程序执行一次后，图片得原始尺寸被代码更改了，再执行就会图片变形了 Sub save_pic() Dim p As Shape, ph As Single, pw As Single, pn As String Dim ph1 As Single, pw1 As Single, n As Integer, p1 As ChartObject Dim fileName As String, t t = Timer '记录开始时间 '当前工作簿下面建立一个导出图片文件夹 fileName = ThisWorkbook.Path & "导出图片1" If Dir(fileName, vbDirectory) = "" Then MkDir (fileName) For Each p In ActiveSheet.Shapes 'type属性查看p得格式，8表示控件格式，不是控件格式才执行 If p.Type <> 8 Then n = n + 1 '记录数量 '记录图片左上角单元格偏移5列单元格值 pn = p.TopLeftCell.Offset(0, -5).Value ph1 = p.Height '记录当前图片尺寸 pw1 = p.Width '原始尺寸，msotrue是图片原始尺寸放大 p.ScaleHeight 1, msoTrue, msoScaleFromTopLeft ph = p.Height '记录放大后的尺寸 pw = p.Width On Error Resume Next '遇到错误强制执行 p.CopyPicture '复制 图片 '创建一个相同尺寸的chartobject对象 Set p1 = ActiveSheet.ChartObjects.Add(0, 0, pw, ph) p1.Select '2010版本以上如果没这句导出会成为空白图片 With p1.Chart .Paste '粘贴 '在当前文件路径下保存为png图片 .Export fileName & "" & pn & ".png", "png" .Parent.Delete '删除 End With '不锁定纵横比 p.DrawingObject.ShapeRange.LockAspectRatio = False p.Width = pw1 '调整回来原来尺寸 p.Height = ph1 End If Next p = Nothing '清空2个对象 p1 = Nothing MsgBox "共成功导出" & n & "张图片，共耗时：" & _ Format(Timer - t, "0.00秒"), vbOKOnly, "导出图片" End Sub |
若是你看不懂又想学的话，就得先去学一下基础，了解一下再来看了。
不过这个文件可得自己保存好，同样的事情我可不想做第二次。
说完企鹅妹便起身准备离开，回头对那还没回过神来的雨夜说了句：“若是你真学vba了，遇到任何问题都可以来找我。”说完随手扔了个小册子就不见了踪影。
雨夜打开小册子认真的看了起来，册子里的内容如下：
详细解释
• 创建文件夹
fileName = ThisWorkbook.Path & "导出图片1" If Dir(fileName, vbDirectory) = "" Then MkDir (fileName) |
Dir函数参中参数
fileName 用来表示搜索路径
vbDirectory用来指定目录或文件夹以及不带属性的文件。
如果不存在该路径或不带属性的文件就返回空，MkDir是根据路径(地址)直接创建文件夹
如果【导出图片1】文件夹不存在就创建一个，存在就下一步
• Type解释
常用得Type格式
名称 | 值 | 说明 |
msoAutoShape | 1 | 自选图形。 |
msoCallout | 2 | 标注。 |
msoCanvas | 20 | 画布。 |
msoChart | 3 | 图。 |
msoComment | 4 | 批注。 |
msoDiagram | 21 | 图表。 |
msoEmbeddedOLEObject | 7 | 嵌入的 OLE 对象。 |
msoFormControl | 8 | 窗体控件。 |
msoFreeform | 5 | 任意多边形。 |
msoGroup | 6 | 组合。 |
msoIgxGraphic | 24 | SmartArt 图形 |
msoInk | 22 | 墨迹。 |
msoInkComment | 23 | 墨迹批注。 |
msoLine | 9 | 线条。 |
msoLinkedOLEObject | 10 | 链接 OLE 对象。 |
msoLinkedPicture | 11 | 链接图片。 |
msoMedia | 16 | 媒体。 |
msoOLEControlObject | 12 | OLE 控件对象。 |
msoPicture | 13 | 图片。 |
msoPlaceholder | 14 | 占位符。 |
msoScriptAnchor | 18 | 脚本定位标记。 |
msoShapeTypeMixed | -2 | 混和形状类型。 |
msoTable | 19 | 表。 |
msoTextBox | 17 | 文本框。 |
msoTextEffect | 15 | 文本效果。 |
• Shape常用属性
.Height 表示图片得高度
.Width 表示图片得宽度
.TopLeftCell 表示图表左上角单元格
这个属性比较常用，如果判断所在得行就是.TopLeftCell.Row
.CopyPicture 复制图片
• ScalaHeight属性解释
按照比例调整图片尺寸
方法：ScalaHeight Factor, RelativeToOriginalSize, Scale
这里是按照原始尺寸放大
• 创建ChartObjects解释
Set p1 = ActiveSheet.ChartObjects.Add(0, 0, pw, ph)
Add后面参数是，左、上、宽度、高度
这里左边距离用0，上面距离也是0，宽度和高度用放大后图片尺寸
p1.Select '2010版本以上如果没这句导出会成为空白图片 With p1.Chart .Paste '粘贴 '在当前文件路径下保存为png图片 .Export fileName & "" & pn & ".png", "png" .Parent.Delete '删除 End With |
这里创建一个空白得Chart对象，因为这个对象有另存为文件得属性，利用这个把图片复制到Chart上保存出去
P1.select 是容错代码，防止2010以上版本office保存出去空白图片问题
原始文件地址(因为原始文件涉及公司机密，文件改为只有10行得精简版本)
链接：https://pan.baidu.com/s/131ITQrCP8bqXa-D7mvi-nw
提取码：shxe
“都说看着枯燥的东西容易犯困，雨夜却没看得津津有味的，似乎她已经找到了修炼这技能的方法，你就不怕她自学成才？”一旁的土豆哥对着企鹅妹说道。
“都是过来人，这条路有那么好走吗？身边有这么强劲的师父她要轻易放过了，损失的又不是我。”企鹅妹淡淡的说着。
“哈哈哈哈，走吧吃饭去，今天晚上吃啥？”土豆哥说道
“随便，反正你掏钱！”企鹅妹说
“那我去买两桶泡面”，话音刚刚落，土豆哥就不见了身影。
未完待续......
今天的分享就到这，如果教程对大家有用，希望大家多多分享点赞支持小编哦！你的每一次点赞和转发都是支持小篇坚持原创的动力。
推荐学习★★★★★
请扫码下载O(∩_∩)O哈哈~
2070
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
