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

boss_zc

没有老师愿意伸把手啊？！

boss_zc

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

蓝桥老师您好，

如果我想通过选择任意文件夹的方式来导入照片，也就是说照片不在“ThisWorkbook.path”下。

该怎么改呢？

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim rng As Range, ML, MT, MW, MH, shp As Shape, n%, jg
   
3.     On Error Resume Next
   
4.     Sheet1.Activate
   
5.     For Each shp In ActiveSheet.Shapes
   
6.         If shp.Type = 1 Or shp.Type = 13 Then
   
7.             shp.Delete
   
8.         End If
   
9.     Next
   
10.     With Application.FileDialog(msoFileDialogOpen)
    
11.         .AllowMultiSelect = True
    
12.         .Show
    
13.         For i = 1 To .SelectedItems.Count
    
14.             filenm = .SelectedItems(i)
    
15.             myName = Dir(filenm)
    
16.             If myName <> "" Then
    
17.                 ML = 54.75
    
18.                 MT = 78.75
    
19.                 MW = 277.5
    
20.                 MH = 127.5: jg = 0
    
21.                 n = n + 1
    
22.                 If n > 3 Then n = 1: MT = MT + MH + jg: ML = 54.75
    
23.                 ML = n * MW - 222.75
    
24.                 ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    
25.                 Selection.ShapeRange.Fill.UserPicture myPath & myName
    
26.             End If
    
27.         Next
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     [a1].Select
    
31.     If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
    
32. End Sub
    

复制代码

打开对话框选择多个图片文件即可。

boss_zc

蓝桥玄霜 发表于 2015-4-4 10:22
打开对话框选择多个图片文件即可。

蓝桥老师，

这个代码我运行时有一点问题，4张图片以内排列没有问题，5张及以上就会出现覆盖现象（最多显示4张，其余的都被这4张覆盖了）。
问题可能出现在以下代码中：
                n = n + 1
                If n > 3 Then n = 1: MT = MT + MH + jg: ML = 7
                ML = n * MW - 270
                ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
                Selection.ShapeRange.Fill.UserPicture myPath & myName

蓝桥玄霜

1. Sub lqxs()
   
2.     Dim rng As Range, ML, MT, MW, MH, shp As Shape, n%, jg
   
3.     On Error Resume Next
   
4.     Sheet1.Activate
   
5.     For Each shp In ActiveSheet.Shapes
   
6.         If shp.Type = 1 Or shp.Type = 13 Then
   
7.             shp.Delete
   
8.         End If
   
9.     Next
   
10.     ML = 54.75: MT = 78.75: MW = 277.5: MH = 127.5
    
11.     With Application.FileDialog(msoFileDialogOpen)
    
12.         .AllowMultiSelect = True
    
13.         .Show
    
14.         For i = 1 To .SelectedItems.Count
    
15.             filenm = .SelectedItems(i)
    
16.             myName = Dir(filenm)
    
17.             If myName <> "" Then
    
18.                 n = n + 1
    
19.                 If n > 3 Then n = 1: MT = MT + MH: ML = 54.75
    
20.                 ML = n * MW - 222.75
    
21.                 ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
    
22.                 Selection.ShapeRange.Fill.UserPicture myPath & myName
    
23.             End If
    
24.         Next
    
25.     End With
    
26.     Application.ScreenUpdating = True
    
27.     [a1].Select
    
28.     If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
    
29. End Sub
    
30. 
    

复制代码

boss_zc

蓝桥玄霜 发表于 2015-4-5 08:58

谢谢蓝桥老师，

新代码运行正常，完全满足要求！

非常感谢！

v111v111v

实在感想，能玩扑克牌了