图片对齐方法

闻启学

有个工作表 里面有几张图片

   利用代码无法将图片对齐 在单元格中  图片有两个是旋转的  请各位高手指导下

插入图片求助.zip (75.44 KB, 下载次数: 16)

2020-2-27 22:57 上传

点击文件名下载附件

chxw68

这样修改将图片大小调整合适了，但位置还是不到位，下午有空再研究吧。

1. Sub test()
   
2.   Dim shp As Shape, ad$
   
3.   For Each shp In ActiveSheet.Shapes
   
4.     If shp.Type = msoAutoShape Then
   
5.       ad = shp.TopLeftCell.Address
   
6.       With shp
   
7.           If .Rotation = 0 Then
   
8.             .Top = Range(ad).Top
   
9.             .Left = Range(ad).Left
   
10.             .Height = Range(ad).Height
    
11.             .Width = Range(ad).Width
    
12.           Else
    
13.             .Top = Range(ad).Top
    
14.             .Left = Range(ad).Left
    
15.             .Height = Range(ad).Width
    
16.             .Width = Range(ad).Height
    
17.           End If
    
18.       End With
    
19.     End If
    
20.   Next
    
21. End Sub

复制代码

闻启学

chxw68 发表于 2020-2-28 12:05
这样修改将图片大小调整合适了，但位置还是不到位，下午有空再研究吧。

这也是我不明解地方  会走位的

chxw68

加减一个数值，变通处理一下。看其他大侠有没有办法。

zopey

图片中心 与  单元格中心 重合即可。

蓝桥玄霜

1. Sub lqxs()
   
2. Dim shp As Shape, ad$, tx$, d, Arr, i%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Arr = [b1].CurrentRegion
   
5. For i = 1 To UBound(Arr)
   
6.     If Arr(i, 1) <> "" Then d(Arr(i, 1)) = Cells(i, 2).Address
   
7. Next
   
8. For Each shp In ActiveSheet.Shapes
   
9.     If shp.Type = msoAutoShape Then
   
10.     tx = shp.AlternativeText
    
11.     If d.exists(tx) Then
    
12.     ad = d(tx)
    
13.     With shp
    
14.         If .Rotation <> 0 Then .Rotation = 0
    
15.         .Top = Range(ad).Top
    
16.         .Left = Range(ad).Left
    
17.         .Height = Range(ad).Height
    
18.         .Width = Range(ad).Width
    
19.     End With
    
20.     End If
    
21.     End If
    
22. Next
    
23. End Sub
    

复制代码

闻启学

zopey 发表于 2020-2-28 17:52
图片中心 与  单元格中心 重合即可。

指导下  完成不知道怎样做

闻启学

蓝桥玄霜 发表于 2020-2-28 18:48

前辈 你理解错了，图片是旋转，对齐时候 都是要保持旋转的 ，还有一个 你这里字典的作用 ？？

蓝桥玄霜

我发现图片的属性中与B列单元格的内容，因此根据这个关联，把图片放到对应的位置。
字典的作用是把图片名与单元格地址关联。
你的要求是不需要旋转直接放入单元格？

zopey

1. Sub lqxs()
   
2. Dim shp As Shape, ad$, tx$, d, Arr, i%
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. 
   
5. Arr = [b1].CurrentRegion
   
6. For i = 1 To UBound(Arr)
   
7.     If Arr(i, 1) <> "" Then d(Arr(i, 1)) = Cells(i, 2).Address
   
8. Next
   
9. 
   
10. For Each shp In ActiveSheet.Shapes
    
11.   If shp.Type = msoAutoShape Then
    
12.     tx = shp.AlternativeText
    
13.     If d.exists(tx) Then
    
14.       ad = d(tx)
    
15.       With shp
    
16.         If .Rotation = 0 Then
    
17.            .Height = Range(ad).Height
    
18.         Else
    
19.            .Width = Range(ad).Height
    
20.         End If
    
21.         
    
22.         .Top = (Range(ad).Top + Range(ad).Offset(1, 0).Top - .Height) / 2
    
23.         .Left = (Range(ad).Left + Range(ad).Offset(0, 1).Left - .Width) / 2
    
24. 
    
25.       End With
    
26.     End If
    
27.   End If
    
28. Next
    
29. End Sub

复制代码