現在選択中の画像のクリック位置を起点として

質問

現在選択中の画像のクリック位置を起点として
長さ２ｃｍ高さ３ｃｍ、太さ1mｍ赤の色の長方形の枠を挿入する。

これはマクロで実行可能でしょうか。もし可能だったらやり方を教えて下さい。m(__)m
Excel2007です。

マクロで記録しても”現在選択中”という条件でまずつまづきます。
Active.Pictureなんてやってもうまくいきません。

回答No.1

mitarashi · ベストアンサー

目的の画像に、右クリック／マクロの登録で、下記shp_clickを設定します。
画像をクリックすると、その点を起点に長方形が描画されるつもりです。xl2010で試しています。ご参考まで。

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Type POINTAPI
x As Long
y As Long
End Type

'ここは一般的な環境に合わせています。
Const DPI As Long = 96 'Pixel per inch
Const PPI As Long = 72 'Point per inch

Sub shp_click()
Dim lpPoint As POINTAPI
Dim lngResult As Long
Dim rectWidth As Double, rectHeight As Double
Dim shp As Shape
Dim pointX As Single, pointY As Single
Dim zoomX As Single, zoomY As Single

lngResult = GetCursorPos(lpPoint)
Call realZoomRate(zoomX, zoomY)
pointX = (lpPoint.x - ActiveWindow.PointsToScreenPixelsX(0)) * PPI / DPI / zoomX
pointY = (lpPoint.y - ActiveWindow.PointsToScreenPixelsY(0)) * PPI / DPI / zoomY

rectHeight = Application.CentimetersToPoints(3)
rectWidth = Application.CentimetersToPoints(2)
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, pointX, pointY, rectWidth, rectHeight)
shp.Fill.Visible = msoFalse
With shp.Line
.Visible = msoTrue
.ForeColor.RGB = vbRed
.Weight = Application.CentimetersToPoints(0.1)
.Transparency = 0
End With

End Sub

'真のズーム倍率を求める 'by kanabunさん
Private Sub realZoomRate(ByRef zoomX As Single, ByRef zoomY As Single)
Dim c As Range
Dim dotX As Long
Dim dotY As Long
Dim dotX1 As Long
Dim dotY1 As Long

Set c = Range("a1")
With ActiveWindow
' ---------- 実際のZoom比の計算 ---------------
dotY = c.Height * DPI / PPI
dotY1 = dotY * .Zoom / 100
zoomY = dotY1 / dotY '実際に適用されているZoom率
dotX = c.Width * DPI / PPI
dotX1 = dotX * .Zoom / 100
zoomX = dotX1 / dotX
End With
End Sub

'おまけ すべてのShapeにクリック時のマクロを設定
'写真だろうが、オートシェープだろうが見境無しです。
'shapeのタイプにより分岐する必要があるでしょう
Sub setMacro()
Dim shp As Shape

For Each shp In ActiveSheet.Shapes
shp.OnAction = "shp_click"
Next shp
End Sub

お礼

ありがとうございます！大変助かりましたm(__)m