Board logo

標題: [分享] (已解決,感謝版主的指導)請問有關於註解放大圖片問題 [打印本頁]
作者: cmo140497    時間: 2012-2-20 10:54     標題: (已解決,感謝版主的指導)請問有關於註解放大圖片問題

本帖最後由 cmo140497 於 2012-2-20 17:34 編輯

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

[attach]9665[/attach]

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


[attach]9666[/attach]

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

[attach]9667[/attach]
作者: Hsieh    時間: 2012-2-20 13:20

回復 1# cmo140497
參考這篇

    http://chijanzen.net/wp/?p=289
[attach]9668[/attach]
作者: GBKEE    時間: 2012-2-20 14:00

回復 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    時間: 2012-2-20 17:31

回復 2# Hsieh


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

回復 3# GBKEE


    感謝版主的指導,儲存格的放大效果真的不錯,十分感謝!
作者: cmo140497    時間: 2012-2-20 18:49

回復 3# GBKEE


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

[attach]9675[/attach]
作者: cmo140497    時間: 2012-2-20 19:06

回復 5# cmo140497


    Dear GB版主 :
再請教一下,這個程式可否改掛在THIS WORKBOOK上,小弟想讓每一SHEET都有這個功能,而不是只有SHEET1,不好意思,再麻煩您指正一下了!
小弟用ActiveSheet.Copy,它只是copy第一次,後面就不會了,
[attach]9676[/attach]
作者: GBKEE    時間: 2012-2-21 08:37

回復 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    時間: 2012-2-21 12:56

回復 8# GBKEE


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)