エクセルで描画のコントロール２

質問

エクセルで直線を描画する時にセルの境界線の交点の座標を基点とする場合、Altキーを使って書きます。この機能をマクロで実現することは可能ですか？出来れば、セルの範囲を限定して、その範囲以外だと、描画自体が出来ないようにしたいのですが。(入力はマウス行いたいのでAltキーの擬似的入力の切り替えがポイントになるのでしょうか？)
また、エクセル標準の描画の場合、複数回直線の入力を行う場合、１回１回直線のアイコンをクリックする必要があると思いますが、連続入力って出来ないのでしょうか？どなたか？詳しい方宜しくお願いいたします。

回答No.4

KenKen_SP · ベストアンサー

EXCEL_VBA さん、Wendy02 さん、koko88okok さん、こんにちは。お邪魔します。

結論としては #1 ご回答で、あえて VBA でやるまでも無い気がしますが、
面白そうなので参加します。私も色々と試してたのですが、気付いたら時間
が経ってしまいました。激しく遅レスですが(´・ω・`)

C が分かるとのことなので、細かな解説はしません。

Excel のオートシェープは指定した位置と若干異なる位置に書かれてしまう
場合があるので 100 ％正確にプロットすることは不可能です。これは Excel
の仕様なのでどうしようもありませんが、0.25ポイント内外程度の誤差を
許容する精度でよければ下記のような方法で実現できそうです。

以下の2つのサンプルでは、マクロを実行し、Msgbox の OK をクリックした
後２秒後のカーソル位置にシェープを書き込んでいます。

もっとも今回のご質問内容は、keybd_event API などで[Alt]キー押下を
シミュレートしてやれば、細かな座標表計算が不要だと思いますが....

一番厄介なのは、ワークシート上でのマウス左クリックの検知でしょうね。

要は WH_MOUSE メッセージをフックすれば良いのですが、Excel ではどう
やってもうまくいきそうもありませんでした。

　# もともと VB(A) 単独でグローバルフックはできないし。

特別な外部コンポーネントを使用しない方法となると、Userform ＋ DirectInput
による方法しかないような気がします。フックより簡単ですよ。

どんなもんでしょう？

Option Explicit

' Win32Api
Private Declare Function GetDC Lib "user32.dll" ( _
　　ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
　　ByVal hWnd As Long, _
　　ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
　　ByVal hDC As Long, _
　　ByVal nIndex As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
　　ByRef lpPoint As POINTAPI) As Long
Private Type POINTAPI
　　x As Long
　　y As Long
End Type
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Const LOGPIXELSX = 88　' x 方向の１論理インチ当たりのピクセル数
Private Const LOGPIXELSY = 90　' y 方向の１論理インチ当たりのピクセル数
Private mKx　　 As Double　　　' x 方向ピクセル-->ポイント変換係数
Private mKy　　 As Double　　　' y 方向ピクセル-->ポイント変換係数
Private mZoomKx As Double　　　' x 方向ウインドウ表示倍率補正係数
Private mZoomKy As Double　　　' y 方向ウインドウ表示倍率補正係数

' ピクセル→ポイント変換係数を求める
Private Sub GetPixelToPointKNum()
　　Dim hDC As Long
　　hDC = GetDC(0&)　' 0: Desktop Window
　　If hDC <> 0 Then
　　　　mKx = CDbl(72# / GetDeviceCaps(hDC, LOGPIXELSX))
　　　　mKy = CDbl(72# / GetDeviceCaps(hDC, LOGPIXELSY))
　　　　Call ReleaseDC(0&, hDC)
　　End If
End Sub

' ウインドウ表示倍率による補正係数を求める
Private Sub GetFixKnum()
　　Dim tmp As Double
　　If mKx * mKy Then Call GetPixelToPointKNum
　　With ActiveWindow
　　　　mZoomKx = CDbl(.Zoom) / 100#
　　　　tmp = 72# * CDbl(ActiveSheet.Range("A1").Height) / mZoomKx
　　　　mZoomKy = tmp * mZoomKx / tmp
　　End With
End Sub

' カーソル位置にシェープを書き込むサンプル
Sub TestMacro1()
　　Dim Cur As POINTAPI
　　Dim Shp As Shape
　　Dim x　 As Single
　　Dim y　 As Single
　　Dim t　 As Long
　　Call GetPixelToPointKNum
　　Call GetFixKnum
　　MsgBox "2秒後のカーソル位置にシェープを書き込みます"
　　t = timeGetTime()
　　While t + 2000 > timeGetTime()
　　　　DoEvents
　　Wend
　　Call GetCursorPos(Cur)
　　With ActiveWindow
　　　　x = CDbl((Cur.x - .PointsToScreenPixelsX(0)) * mKx / mZoomKx)
　　　　y = CDbl((Cur.y - .PointsToScreenPixelsY(0)) * mKy / mZoomKy)
　　End With
　　ActiveSheet.Shapes.AddShape msoShapeRectangle, x, y, 100, 100
End Sub

' カーソル位置のセルにぴったりとくっつけてシェープを書き込むサンプル
Sub TestMacro2()
　　Dim Cur As POINTAPI
　　Dim Pos As Object ' Range or Shape なので Object
　　Dim x　 As Single
　　Dim y　 As Single
　　Dim t　 As Long
　　MsgBox "2秒後のカーソル位置付近のセル左角にシェープを書き込みます"
　　t = timeGetTime()
　　While t + 2000 > timeGetTime()
　　　　DoEvents
　　Wend
　　Call GetCursorPos(Cur)
　　Set Pos = ActiveWindow.RangeFromPoint(Cur.x, Cur.y)
　　If UCase$(TypeName(Pos)) = "RANGE" Then
　　　　x = Pos.Left
　　　　y = Pos.Top
　　　　ActiveSheet.Shapes.AddShape msoShapeRectangle, x, y, 100, 100
　　End If
End Sub

補足

ご丁寧にありがとうございます。
確かに#1の方法でやるしかないかなぁ？って思いましたが、#1の方法では、入力範囲の制限が出来ないように思いました。
また、早速、動かしてみましたが、四角が書かれるだけでした。多分ヒントとしては、最重要事項だと思うのですが、この例ですと、やはり、インターバルタイマーを使用して、定期的にTestMacroを呼び出す必要があるのでしょうか？
もう少し、詳しく教えていただけないでしょうか？
追伸！
>C が分かるとのことなので、細かな解説はしません。
どこで、どう間違えれば、私が、C言語が解ると勘違いされるのか？と疑問に思っておりましが、関心カテゴリーが一式選択されていたからなんですね？大変失礼しました。(爆笑+選択した記憶がない)
ちゃんと、気になるカテゴリーに変更しておきましたので、今後とも宜しくお願いいたします。