如何将一个自选图形的底纹通过vba转到另一个自选图形中？

lj1226189

底纹.rar (1.36 MB, 下载次数: 15)

2014-9-3 06:34 上传

点击文件名下载附件

谢谢！

lj1226189

没有人帮我 只好再顶一下了！

芐雨

用了比较迂回的方法，这问题发到VBA区可能比较多人回答

用VBA底纹填充_芐雨.rar (1.36 MB, 下载次数: 36)

2014-9-3 11:53 上传

点击文件名下载附件

lj1226189

多谢大侠 确实可以实现了 太感谢了！ 转化后图形底色中出现一个白的十字 不知是什么原因 能否麻烦大侠再帮我看一下

芐雨

lj1226189 发表于 2014-9-3 15:10
多谢大侠 确实可以实现了 太感谢了！ 转化后图形底色中出现一个白的十字 不知是什么原因 能否麻烦大侠再帮我 ...

那白色十字是图片平铺出现，应该除不掉，修改成填充整个形状就可以

1. Sub shpFill()
   
2.     Dim myPath$, shp As Shape
   
3.     Set shp = ActiveSheet.Shapes("矩形 1")
   
4.     Application.ScreenUpdating = False
   
5.     shp.Copy  '复制图形
   
6.     ActiveSheet.Paste  '粘贴图形
   
7.     With Selection     '去边框后复制
   
8.         .ShapeRange.Line.Visible = msoFalse
   
9.         .Copy
   
10.         .Delete
    
11.     End With
    
12.     myPath = ThisWorkbook.Path & "\myPic.jpg"    '文件保存路径
    
13. 
    
14.     '创建图表，大小同shp
    
15.     With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
    
16.         .Paste
    
17.         .Export myPath    '另存jpg文件
    
18.         .Parent.Delete
    
19.     End With
    
20.     ActiveSheet.Shapes("矩形 2").Fill.UserPicture myPath    '文件填充
    
21.     Kill myPath          '删除jpg文件
    
22.     Application.ScreenUpdating = True
    
23. End Sub

复制代码

lj1226189

苄大侠 太厉害了 佩服之至！
对了我想如果我有一级图片 名是1 、2、3、4、现在通过循环将底色填充到名称为6，12，18，24 图片如何能做到！

再次感谢！

芐雨

1. Sub shpFill()
   
2.     Dim myPath$, shp As Shape
   
3.     Dim arr, brr
   
4.     arr = Array("1", "2", "3", "4")
   
5.     brr = Array("6", "12", "18", "24")
   
6.     For i = 0 To UBound(arr)
   
7.         Set shp = ActiveSheet.Shapes(arr(i))
   
8.         Application.ScreenUpdating = False
   
9.         shp.Copy  '复制图形
   
10.         ActiveSheet.Paste  '粘贴图形
    
11.         With Selection     '去边框后复制
    
12.             .ShapeRange.Line.Visible = msoFalse
    
13.             .Copy
    
14.             .Delete
    
15.         End With
    
16.         myPath = ThisWorkbook.Path & "\myPic.jpg"    '文件保存路径
    
17. 
    
18.         '创建图表，大小同shp
    
19.         With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart
    
20.             .Paste
    
21.             .Export myPath    '另存jpg文件
    
22.             .Parent.Delete
    
23.         End With
    
24.         ActiveSheet.Shapes(brr(i)).Fill.UserPicture myPath    '文件填充
    
25.         Kill myPath          '删除jpg文件
    
26.     Next
    
27.     Application.ScreenUpdating = True
    
28. End Sub
    

复制代码

lj1226189

非常感谢！楼上大侠是真正的高手！