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

質問

エクセルで直線を描画する時にセルの境界線の交点の座標を基点とする場合、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言語が解ると勘違いされるのか？と疑問に思っておりましが、関心カテゴリーが一式選択されていたからなんですね？大変失礼しました。(爆笑+選択した記憶がない)
ちゃんと、気になるカテゴリーに変更しておきましたので、今後とも宜しくお願いいたします。

回答No.3

Wendy02

#2の修正：

>コントロールが、どうも階層的に出来ているような気がするので、マウスから座標が取れないのです。

以上の「・・・、マウスから座標が～」
「マウスから座標は取れても、Application からの座標なので、ワークシートからの座標ではないのです。」

(解説：Applicationの(0,0)の座標と、ワークシートの(0,0)の座標との位置を差し引きすればよいと思うかもしれませんが、ワークシートの(0,0)座標は、仮に全画面表示しても、ツールバーなどがあり、ワークシートも、Applicationの上に乗っているだけで、Applicationに対して、固定位置にあるわけではありません。図形描画は、ワークシートの(0,0)からの位置を基準としていますから、うまく行きません。私の知っている範囲では、その内部位置をマウスポインタで、つまり外部から取る方法が分からないのです。しかし、「ない」といえないのです。)

お礼

お返事ありがとうございます。
正直言って驚いています。難しいことなんですね？
私の力量の範囲を超えていると思いますが、教えて頂ければがんばって勉強したいと思います。宜しくお願いいたします。

回答No.2

Wendy02

こんにちは。

すごくつまらないことをダラダラと書きますが、お許しください。

回答ではありませんが、No. 2489577 の#1の補足にある件とあわせての発言なのですが、それに取り組んだ経験があります。

細かい説明は、実現していないのだから、やめておきますか、VBでは、コントロールそのものが一つのWindowなのですが、Excelは複合的に作られているので、ワークシート側の座標位置がマクロで取れません。セルは確かに、座標位置を持っているのですが、前回のマクロを書いた方では満足されなかったのは、必ずしも、セルを対象にして図形描画のラインを引くわけではない、ということだと思います。

VB(VB6)やVB.Netには、そういうようなことが可能ですが、Excelでは、コントロールが、どうも階層的に出来ているような気がするので、マウスから座標が取れないのです。

同じようなご質問は、昔から、時々、見かけるのですが、Win32 APIバリバリの正解があるのかもしれませんが、私自身は、その実現を見たことはありません。要するに究極的には、図形描画の座標をマウスポインタで取ることと同義だと、私は思っています。それさえ出来れば、問題は解決するのだと思います。

私のマクロへの考え方の中に、そうしたマニュアルの延長上(手作業という意味)のユーティリティを作る意欲がなくなってしまったので、もう１年以上、そのままになっています。開発の苦労が多いわりに、実が少ないような気がしているからなのです。もう一つは、Win32 APIをマクロに積極的に取り組もうという気持ちがないのも遠因しているのです。時代的に、VBA自体にもカゲリを感じているからです。

諦めないで、もう少し開けておいてみてください。もしかしたら、前の質問と合わせて、ここに回答してくれる方がいらっしゃるかもしれません。私個人も、ここが開いている限りは、前のご質問と合わせて、しばらく考えてみるつもりです。余計な話を書いて、すみません。

回答No.1

koko88okok

直線などのボタンをダブルクリックすると連続して描画できます。
止める時は、クリックすると凹んでいたボタンが元に戻ります。

ちなみに、「書式のコピー/貼り付け」ボタンも同じように動作します。