[分享] (已解決,感謝版主的指導)請問有關於註解放大圖片問題

cmo140497

Dear 各位先拜 :
小弟爬文發現不用巨集寫註解放大圖片的範例,這是怎麼做到的?

[attach]9665[/attach]

http://forum.twbts.com/viewthread.php?tid=5738

下載 (172.62 KB)

2012-2-20 11:29

原來是註解格式,歹勢,未爬文即亂發文,如果要靠巨集的話,請問各位前輩,要如何指定A欄位的所有圖片自動加入有A欄位圖片的註解(有放大的效果)?謝謝!

自動入加註解插入圖片放大.rar (25.24 KB)

下載次數: 10

2012-2-20 11:34

Hsieh

回復 1# cmo140497
參考這篇

    http://chijanzen.net/wp/?p=289
自動入加註解插入圖片放大.rar (51.32 KB)

下載次數: 11

2012-2-20 13:20

GBKEE

回復 1# cmo140497
工作表1 的事件程式碼

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     Dim Msg As Boolean, xlP  As Shape
   
3.     On Error Resume Next
   
4.     Pictures("COPY").Delete
   
5.     For Each xlP In Me.Shapes
   
6.         If xlP.TopLeftCell.Address = Target.Address Then
   
7.             Msg = True
   
8.             Exit For
   
9.         End If
   
10.     Next
    
11.     If Msg = False Then Exit Sub
    
12.     Selection.Copy
    
13.     With ActiveSheet.Pictures.Paste
    
14.         .Select
    
15.         .Name = "Copy"
    
16.         .Formula = Target.Address
    
17.         .Top = Target.Offset(1, 2).Top
    
18.         .Left = Target.Offset(, 2).Left
    
19.         .Height = Target.Height * 5
    
20.         .Width = Target.Height * 5
    
21.         .ShapeRange.Line.Visible = msoTrue
    
22.         .ShapeRange.Line.ForeColor.SchemeColor = 64
    
23.         .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
24.     End With
    
25.     Target.Select
    
26. End Sub

複製代碼

cmo140497

回復 2# Hsieh


    感謝版主的指導,這個網站先前小弟有花時間,下載各種範例來參考,沒想到這樣也可以拿來引用,不過看了之後,對小弟實在有點困難,不過仍感謝版主的指導,謝謝!

cmo140497

回復 3# GBKEE


    感謝版主的指導,儲存格的放大效果真的不錯,十分感謝!

cmo140497

回復 3# GBKEE


    Dear 版主 :
不好意思,又遇到一個小問題,為何小弟作了ActiveSheet.Copy,為了它只copy了sheet1可作放大作用一次,其它sheet並沒有相對著作copy,感謝!

下載 (131.1 KB)

2012-2-20 18:48

GetSINF_test.rar (18.05 KB)

下載次數: 3

2012-2-20 18:48

cmo140497

回復 5# cmo140497


    Dear GB版主 :
再請教一下,這個程式可否改掛在THIS WORKBOOK上,小弟想讓每一SHEET都有這個功能,而不是只有SHEET1,不好意思,再麻煩您指正一下了!
小弟用ActiveSheet.Copy,它只是copy第一次,後面就不會了,
GetSINF_test.rar (18.05 KB)

下載次數: 7

2012-2-20 19:06

GBKEE

回復 7# cmo140497
ThisWorkbook模組的事件程式

1. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
2.     Dim Msg As Boolean, xlP  As Shape
   
3.     On Error Resume Next
   
4.     Sh.Pictures("COPY").Delete
   
5.     For Each xlP In Sh.Shapes
   
6.         If xlP.TopLeftCell.Address = Target.Address Then
   
7.             Msg = True
   
8.             Exit For
   
9.         End If
   
10.     Next
    
11.     If Msg = False Then Exit Sub
    
12.     Selection.Copy
    
13.     With ActiveSheet.Pictures.Paste
    
14.         .Select
    
15.         .Name = "Copy"
    
16.         .Formula = Target.Address
    
17.         .Top = Target.Offset(1, 2).Top
    
18.         .Left = Target.Offset(, 2).Left
    
19.         .Height = Target.Height * 5
    
20.         .Width = Target.Height * 5
    
21.         .ShapeRange.Line.Visible = msoTrue
    
22.         .ShapeRange.Line.ForeColor.SchemeColor = 64
    
23.         .ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    
24.     End With
    
25.     Target.Select
    
26. End Sub

複製代碼

cmo140497

回復 8# GBKEE


   感謝版主,昨天小弟一直在試workbook及worksheet,真不知workbook還可以串Sheetselectionchange,這一次真的受益匪淺,感謝!