请教----VBA实现固定区域导入固定尺寸图片

boss_zc · 发表于 2014-7-19 09:33

本帖最后由 boss_zc 于 2014-7-19 09:33 编辑

请大神帮忙写个代码：

VBA实现-----按钮或实现自定义加载项“贴图”功能
1.将该EXCEL文件根目录下的所有JPG图片以高度4.5mm,长度9.7833mm,第一行（三个图片）排完再排第二行………….第n行
2.在贴图过程中，行6～25之间的高度或距离可以随时变化以适应贴图（即贴图区域不变，行高自由，贴图下区域边框线必须和最后一行照片齐平）

实例在附件里请下载：

将文件夹中的图片贴到指定EXCEL表格中.zip (1.45 MB, 下载次数: 28)

蓝桥玄霜 · 发表于 2014-7-19 10:11

Sub lqxs()
Dim rng As Range, ML, MT, MW, MH, shp As Shape, n%, jg
On Error Resume Next
Sheet1.Activate
For Each shp In ActiveSheet.Shapes
If shp.Type = msoAutoShape Then
shp.Delete
End If
Next
myPath = ThisWorkbook.Path & ""
myName = Dir(myPath & "*.jpg")
ML = 54.75
MT = 78.75
MW = 277.5
MH = 127.5: jg = 15.75
Do While myName <> ""
n = n + 1
If n > 3 Then n = 1: MT = MT + MH + jg: ML = 54.75
ML = n * MW - 222.75
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
Selection.ShapeRange.Fill.UserPicture myPath & myName
myName = Dir
Loop
Application.ScreenUpdating = True
[a1].Select
If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
End Sub

复制代码

蓝桥玄霜 · 发表于 2014-7-19 10:13

请见附件。

boss_zc · 发表于 2014-7-19 11:05

蓝桥玄霜发表于 2014-7-19 10:13
请见附件。

更改说明

boss_zc · 发表于 2014-7-19 11:22

补充说明：
B列到Q列的宽度不变，6行到25行之间的高度可以随图片量的变化而变化。
所有导入图片必须在绿色背景区域内。

蓝桥玄霜 · 发表于 2014-7-19 13:33

中间的间隔都没有，绿色背景就看不见了。
把第15句中的改为：jg=0

boss_zc · 发表于 2014-7-19 19:01

本帖最后由 boss_zc 于 2014-7-19 19:09 编辑

蓝桥玄霜发表于 2014-7-19 13:33
中间的间隔都没有，绿色背景就看不见了。
把第15句中的改为：jg=0

老师；
1.空一行解决了，谢谢！

2.绿色区域下边框还是没有动啊？

&&&&&&&要求和最后一行图片自动齐平。请插看图！

说明2

boss_zc · 发表于 2014-7-19 19:18

由于本人对VBA来说-----菜鸟！
可能信息表达的不清楚,造成老师误解。
@个人觉得，满足条件的代码应该包含：
1.对指定文件夹图片的调取，尺寸控制，安放位置和排列顺序
2.必须对图片区域的行高进行控制。或者添加行也可以----------------必须使绿色区域下边框和最后一行图片下边框齐平
说明3.jpg

boss_zc · 发表于 2014-7-20 12:10

哪位大神帮忙解决一下！

boss_zc · 发表于 2014-7-20 18:44

请大师们帮忙改一下：
图片存放在Range（B6，Q25）当中。
高度范围可以自动变化，列不变。

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

[求助] 请教----VBA实现固定区域导入固定尺寸图片