Board logo

標題: [發問] 請教關於如何讓每一個sheet的圖片均有點擊放大縮小效果 [打印本頁]
作者: cmo140497    時間: 2013-1-8 16:03     標題: 請教關於如何讓每一個sheet的圖片均有點擊放大縮小效果

Dear 大大:
這個問題先前已有發問過,但小弟想要用這個程式將每一個sheet的圖片均做點放大縮小的效果,均不得其效果,可否請大家幫個忙修正一下,感恩!

[attach]13844[/attach]
作者: Hsieh    時間: 2013-1-8 16:43

回復 1# cmo140497
  1. Private Sub Workbook_Open()
  2. Set dic = CreateObject("Scripting.Dictionary")
  3. Dim Sh As Shape
  4. For Each sht In Sheets
  5. For Each Sh In sht.Shapes
  6.    If Sh.Name Like "圖片*" Then Sh.OnAction = "nn": dic(Sh.Name & "h") _
  7.    = Sh.Height:: dic(Sh.Name & "w") = Sh.Width
  8. Next
  9. Next
  10. End Sub
複製代碼
作者: GBKEE    時間: 2013-1-8 16:50

回復 1# cmo140497
試試看
  1. Private Sub Workbook_Open()
  2.     Set dic = CreateObject("Scripting.Dictionary")
  3.     Dim Sh As Worksheet
  4.     Dim S As Shape                  'Shape: 代表圖形層中的物件，如快取圖案、手繪多邊形、OLE 物件或圖片
  5.    
  6.     For Each Sh In Sheets           'Sheets: 工作表 物件的集合
  7.          For Each S In Sh.Shapes    'Shapes: Shape  物件的集合
  8.         If S.Name Like "圖片*" Then S.OnAction = "nn": dic(S.Name & "h") _
  9.             = S.Height: dic(S.Name & "w") = S.Width
  10.         Next
  11.     Next
  12. End Sub

  14. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  15.   '*** 新增程式:   還原 圖片的大小  ******
  16.     Dim Sh As Worksheet
  17.     Dim S As Shape                  'Shape: 代表圖形層中的物件，如快取圖案、手繪多邊形、OLE 物件或圖片
  18.     For Each Sh In Sheets           'Sheets: 工作表 物件的集合
  19.          For Each S In Sh.Shapes    'Shapes: Shape  物件的集合
  20.         If S.Name Like "圖片*" Then S.Height = dic(S.Name & "h"): S.Width = dic(S.Name & "w")
  21.         Next
  22.     Next
  23. End Sub
複製代碼
作者: cmo140497    時間: 2013-1-8 17:01     標題: (已解決)請教關於如何讓每一個sheet的圖片均有點擊放大縮小效果

回復 2# Hsieh


    感謝版主的指正,請教版主為什麼小弟用activesheet.shape反而不行,另為什麼只能用Private Sub Workbook_Open(),而不行用Private Sub Workbook_SheetActivate(ByVal Sh As Object),小弟愚昩,再煩請版主指導一下小弟,謝謝!
作者: cmo140497    時間: 2013-1-8 17:24

回復 3# GBKEE


    Dear 版主 :
可否再請教您,新增圖片是不是一定得存檔,另外sheet1之圖片,點擊反而縮小,sheet2則ok,不知道為什麼?再請您協助指正,感恩!

[attach]13848[/attach]
作者: Hsieh    時間: 2013-1-8 20:13

回復 4# cmo140497

SheetActivate事件程序當然也可以
要用
for each pic in Sh.Shapes
作者: GBKEE    時間: 2013-1-9 15:22

本帖最後由 GBKEE 於 2013-1-9 15:24 編輯

回復 5# cmo140497
新增圖片是不是一定得存檔: 可隨你的意.
Sheet1 4個圖片名稱為 Picture 1,Picture 2,圖片 1,圖片 2
Sheet2 3個圖片名稱為 圖片 3,圖片 2,圖片 1
If Sh.Name Like "圖片*" Then   : 無法讀出Sheet1  Picture 1,Picture 2 的圖片
修改以 圖案類型= 照片,作為判斷.
  1. Private Sub Workbook_Open()
  2.     Set dic = CreateObject("Scripting.Dictionary")
  3.     Dim Sh As Worksheet
  4.     Dim S As Shape                          'Shape: 代表圖形層中的物件，如快取圖案、手繪多邊形、OLE 物件或圖片
  5.     For Each Sh In Sheets                   'Sheets: 工作表 物件的集合
  6.         For Each S In Sh.Shapes             'Shapes: Shape  物件的集合
  7.             If S.Type = msoPicture Then     'S.Type(圖案類型): 照片
  8.                 S.OnAction = "nn"
  9.                 dic(S.Name & "h") = S.Height
  10.                 dic(S.Name & "w") = S.Width
  11.             End If
  12.         Next
  13.     Next
  14. End Sub
  15. Private Sub Workbook_BeforeClose(Cancel As Boolean)
  16.   '*** 新增程式:   還原 圖片的大小  ******
  17.     Dim Sh As Worksheet
  18.     Dim S As Shape                  'Shape: 代表圖形層中的物件，如快取圖案、手繪多邊形、OLE 物件或圖片
  19.     For Each Sh In Sheets           'Sheets: 工作表 物件的集合
  20.         For Each S In Sh.Shapes    'Shapes: Shape  物件的集合
  21.             If S.Type = msoPicture Then S.Height = dic(S.Name & "h"): S.Width = dic(S.Name & "w")
  22.         Next
  23.     Next
  24. End Sub
複製代碼
作者: cmo140497    時間: 2013-1-9 15:39

回復 6# Hsieh


    感謝版主再次地不吝指正,小弟可否再問一個問題,假如圖片如何置中(於儲存格內),謝謝!



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