[英]Programmatically assign macro in Excel to multiple shapes in a range
對於某些人來說,這可能超級容易,但對我而言絕對不是。 我在stock.xlsm工作簿中有一個庫存工作表,其中包含許多產品圖片。 我使用一個名為FitPic()
的宏將它們放入單元格中。 我要求在運行宏時,它將執行其通常的工作,但還要將一個名為ClickResizeImage()
的宏分配給圖片形狀。
Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim Pic As Object
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
If TypeName(Selection) = "DrawingObjects" Then
For Each Pic In Selection.ShapeRange
FitIndividualPic Pic
Next Pic
Else
FitIndividualPic Selection
End If
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro." & " Num" & Count
End Sub
Public Sub FitIndividualPic(Pic As Object)
Dim Gap As Single
Gap = 0.75
With Pic
Pic.Placement = xlMoveAndSize
PicWtoHRatio = (.Width / .Height)
End With
With Pic.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Pic
.Width = .TopLeftCell.Width - Gap
.Height = .Width / PicWtoHRatio - Gap
End With
Case Else
With Pic
.Height = .TopLeftCell.RowHeight - Gap
.Width = .Height * PicWtoHRatio - Gap
End With
End Select
With Pic
.Top = .TopLeftCell.Top + Gap
.Left = .TopLeftCell.Left + Gap
End With
End Sub
這是ClickResizeImage()
,當然,它可以獨立運行。
Sub ClickResizeImage()
Dim shp As Shape
Dim big As Single, small As Single
Dim shpDouH As Double, shpDouOriH As Double
big = 8
small = 1
On Error Resume Next
Set shp = ActiveSheet.Shapes(Application.Caller)
With shp
shpDouH = .Height
.ScaleHeight 1, msoTrue, msoScaleFromTopLeft
shpDouOriH = .Height
If Round(shpDouH / shpDouOriH, 2) = big Then
.ScaleHeight small, msoTrue, msoScaleFromTopLeft
.ScaleWidth small, msoTrue, msoScaleFromTopLeft
.ZOrder msoSendToBack
Else
.ScaleHeight big, msoTrue, msoScaleFromTopLeft
.ScaleWidth big, msoTrue, msoScaleFromTopLeft
.ZOrder msoBringToFront
End If
End With
End Sub
Dim Pic As Shape
(從對象更改)。 然后在Sub FitPic()
FitIndividualPic Pic
行之后立即添加以下代碼: Pic.OnAction = "ClickResizeImage"
。
要明確的是,這應該是您的新FitPic()
:
Public Sub FitPic()
On Error GoTo NOT_SHAPE
Dim Pic As Shape
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
If TypeName(Selection) = "DrawingObjects" Then
For Each Pic In Selection.ShapeRange
FitIndividualPic Pic
Pic.OnAction = "ClickResizeImage"
Next Pic
Else
FitIndividualPic Selection
Selection.OnAction = "ClickResizeImage" 'also assigns the macro to the Selection
End If
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro." & " Num" & Count
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.