VBAでマウスボタンが離された時のセル番地を取得

質問

エクセル2010のVBAを使ってマウスのボタンが離された場所のセル番地を取得することはできますか？　

例えば　
マウスの左ボタンをA5の位置で離したとしたらA5というセル番地が返されるようにしたいです（ボタンを離したときのセルはアクティブセルではないという条件で）。

回答No.3

mitarashi · ベストアンサー

#1,2です。
>（DPI）を１３５％にしてwindowsの文字の大きさを変更していたのが原因のようです。文字の大きさを変更しても正常に表示できるようにすることは可能でしょうか？
そこまでお分かりならご自分で対応されてはどうかと思いますが、DPI、PPIを決め打ちでは無くて環境から取得する様にしてみました。例によって右クリックの事例です。
なお、DPIは縦横別々に取得出来ますが、簡便にX方向の値を採用しています。
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
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.dll" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long

Dim PPI As Long, DPI As Long

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim myMousePt As POINTAPI

Cancel = True
PPI = GetPPI
DPI = GetDPI
GetCursorPos myMousePt
MsgBox screenToCellAddress(myMousePt)
End Sub

Private Function GetPPI() As Long
GetPPI = Application.InchesToPoints(1)
End Function

Private Function GetDPI() As Long
Dim hdc As Long
'X方向のDPIを採用
Const LOGPIXELSX = 88

hdc = GetDC(Application.hWnd)
GetDPI = GetDeviceCaps(hdc, LOGPIXELSX)
Call ReleaseDC(&H0, hdc)
End Function

'ワークシート上のクリックより得られたスクリーン座標をセル座標に変換する
Private Function screenToCellAddress(scrnPOINT As POINTAPI) As String
Dim pointDifX As Single, pointDifY As Single
Dim startX As Single, startY As Single
Dim targetRange As Range
Dim pointX As Single, pointY As Single
Dim zoomX As Single, zoomY As Single
Dim i As Long

'左上隅セルの左上角との距離をポイントに変換
Call realZoomRate(zoomX, zoomY)
pointDifX = (scrnPOINT.X - ActiveWindow.PointsToScreenPixelsX(0)) * PPI / DPI / zoomX
pointDifY = (scrnPOINT.Y - ActiveWindow.PointsToScreenPixelsY(0)) * PPI / DPI / zoomY
startX = ActiveWindow.VisibleRange(1).Left
startY = ActiveWindow.VisibleRange(1).Top
Set targetRange = ActiveWindow.VisibleRange(1)
For i = 1 To ActiveWindow.VisibleRange(1).Column
pointX = pointX + targetRange.Width
Next i
For i = 1 To ActiveWindow.VisibleRange(1).Row
pointY = pointY + targetRange.Height
Next i
Do Until pointX > pointDifX
Set targetRange = targetRange.Offset(0, 1)
pointX = pointX + targetRange.Width
Loop
Do Until pointY > pointDifY
Set targetRange = targetRange.Offset(1, 0)
pointY = pointY + targetRange.Height
Loop
screenToCellAddress = targetRange.Address
End Function

'真のズーム倍率を求める '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

お礼

今度のサンプルコードは正常に動きましたので、このコードと教えていただいたリンク先の内容を参考にじっくり勉強してみます。
何度も回答ありがとうございました。

回答No.2

mitarashi

#1です。
>例えばファイルをA5のセルにドラッグ＆ドロップした時にA5というセル番地を取得したいのです。
当方は何らかのタイミングでGetCursorPosで取得した座標をセル座標に変換する例として提示したのみです。「何らかのタイミング」についてはご質問文からは読み取れませんでした。画像ファイルのドラッグアンドドロップの例を下記に回答しています。
http://okwave.jp/qa/q9069382.html

なお、A5で右クリックしたとき、A7が表示されるとの事ですが、当方もxl2010ですが、シート倍率を振って、画面右下の方まで試しておりますが、問題なく動いていますので、不具合原因は分かりかねます。

補足

サンプルコード実行時の不具合の原因はどうやら「画面の解像度」→「テキストやその他の項目の大きさの変更」→「カスタムテキストサイズの設定（DPI）」を１３５％にしてwindowsの文字の大きさを変更していたのが原因のようです。文字の大きさを変更しても正常に表示できるようにすることは可能でしょうか？

回答No.1

mitarashi

右クリックなら下記のコードで出来ます。（シートモジュールに記述）
※本来Targetに取得できるので、単なる動作サンプルとお考え下さい。
左クリックの場合は適当なイベントが無いので工夫が必要になります。
ループを回しっぱなしにしてクリックを検知するとか、殆ど透明なUserFormでワークシート全体を覆っておいて、UserFormのイベントを利用するとか。このあたりは実際どの様な使い方をしたいかに関わって来ますので現在の情報だけではアドバイス出来ません。
なお、分割表示とか、ウィンドウ枠の固定をしていると誤動作すると思います。
ご参考まで。
Option Explicit

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Const DPI As Long = 96
Private Const PPI As Long = 72

Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
'右クリックしたセルのセル座標を表示
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim myMousePt As POINTAPI

Cancel = True
GetCursorPos myMousePt
MsgBox screenToCellAddress(myMousePt)

End Sub

'ワークシート上のクリックより得られたスクリーン座標をセル座標に変換する
Private Function screenToCellAddress(scrnPOINT As POINTAPI) As String
Dim pointDifX As Single, pointDifY As Single
Dim startX As Single, startY As Single
Dim targetRange As Range
Dim pointX As Single, pointY As Single
Dim zoomX As Single, zoomY As Single
Dim i As Long

'左上隅セルの左上角との距離をポイントに変換
Call realZoomRate(zoomX, zoomY)
pointDifX = (scrnPOINT.X - ActiveWindow.PointsToScreenPixelsX(0)) * PPI / DPI / zoomX
pointDifY = (scrnPOINT.Y - ActiveWindow.PointsToScreenPixelsY(0)) * PPI / DPI / zoomY
startX = ActiveWindow.VisibleRange(1).Left
startY = ActiveWindow.VisibleRange(1).Top
Set targetRange = ActiveWindow.VisibleRange(1)
For i = 1 To ActiveWindow.VisibleRange(1).Column
pointX = pointX + targetRange.Width
Next i
For i = 1 To ActiveWindow.VisibleRange(1).Row
pointY = pointY + targetRange.Height
Next i
Do Until pointX > pointDifX
Set targetRange = targetRange.Offset(0, 1)
pointX = pointX + targetRange.Width
Loop
Do Until pointY > pointDifY
Set targetRange = targetRange.Offset(1, 0)
pointY = pointY + targetRange.Height
Loop
screenToCellAddress = targetRange.Address
End Function

'真のズーム倍率を求める '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

補足

回答ありがとうございます。
コードをコピーし、実行してみましたが私がやりたいこととは違うようです。このコードではセルを右クリックをしたときにメッセージボックスが表示されましたが、私が知りたいのはボタンを離した時のセル番地を取得する方法です。例えばファイルをA5のセルにドラッグ＆ドロップした時にA5というセル番地を取得したいのです。
ちなみにこのコードではA５のセルを右クリックした時にメッセージボックスで$A$７が表示されるという結果でした（分割表示などはしていません）。