【画像内の寸法を測定する】【エクセル2013,VBA】

画像に写し込んだ物差し（大きさがわかっていれば何でも良い）のサイズをもとに画像内の物体の寸法を測定するコード。

最初に

・専用ソフトや携帯アプリでこと足りるならそちらをお勧めします。エクセルでやりたいひと向けです。

・画像の大きさ次第のところもありますが、精度がそこまでよくありません。画像が小さく、表示の拡大を行うと微妙にずれます。

・測定途中でやめると、カーソルが矢印に固定されてしまうので注意してください。

クリック動作の検出

始点と終点をクリックしてその2点の距離を測定したいのだが、クリック動作の検出が必須となる。そのためには主に以下の4つがあるそうです。

1. GetAsyncKeyState API

2. GetMessage API

3. サブクラス化

4. マウスの低レベルフック(グローバルフック)

シート上でマウスイベントを検出する方法 | ヴィーバ VeaBa! Excel VBA Tips

1と2がお手軽だがループ処理が必要なため負荷がかかり、カーソルが青丸（処理中）になってしまったのでボツに（ピンポイントで指定できない）。3,4は難しそうなので回避（4はしっかり理解していないと危険とのコメントも）。

つぎにワークシートファンクションでできないかとも考えたが、画像上だとクリック動作の検出ができなかったのでボツ。

そこで、小手先な感じもするがカーソル位置を返すコードを作成し、画像にいわゆるマクロの登録をすることで、クリック動作の検出と画像上のカーソル位置取得を行うことにした。

以下コードの概要

1.ダイアログボックスから画像ファイルを選択する。

2.画像がシートに読み込まれる。画像にカーソルの位置を返すマクロが登録される。

3.画像上のどこかをクリックすると、カーソルが指の形から矢印に変わる。

4.始点をクリック。

5.終点をクリック。始点から終点まで線が引かれ、線の長さがカラムB、Cに出力されていく(Bはピクセル、Cは物差しの長さをもとに計算された値）。線の左上には通し番号を表示。

以下3〜6を繰り返すと複数回、寸法測定が可能。1回目は基準となる物差しの始点と終点を選択し、物差しのサイズを入力すると以降は物差しのサイズをもとに長さが出力される。

例：将棋盤の枡目を物差しとして駒の寸法を測定

0と1は枡目=3cm

=======================================================

以下コード

Dim state As Long, PosiPix(1 To 2, 1 To 2) As Long
Public Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Type POINTAPI
CPosix As Long
Cposiy As Long
End Type

'メインコード
Sub 寸法測定開始()

ActiveSheet.Pictures.Insert(File選択("画像を選択してください。")).Select
'画像の位置指定
Selection.ShapeRange.Left = 200
Selection.ShapeRange.Top = 10
'画像にマクロの登録を行う（＝クリックされると寸法測定が動作する）
Selection.OnAction = "寸法測定"
Application.Cursor = xlDefault
state = 1
End Sub

'寸法を測定するコード

Sub 寸法測定()
'1回目のクリック→カーソルを指から矢印に変える
'2回目のクリック→開始点を記録
'3回目のクリック→開始点と終了点に破線をひき距離を書き出す

Dim i As Long

Select Case state 'stateにより何回目のクリックか判別

Case 2 '2回目のクリックなら

'開始点の座標を記憶
PosiPix(1, 1) = GCPPixX
PosiPix(1, 2) = GCPPixY
state = 3

Case 3 '3回目のクリックなら
'終了点の座標を記憶

PosiPix(2, 1) = GCPPixX
PosiPix(2, 2) = GCPPixY

'開始点と終了点に破線をひく
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, PosiPix(1, 1), PosiPix(1, 2), PosiPix(2, 1), PosiPix(2, 2)). _
Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.DashStyle = msoLineSysDot
.Weight = 0.5
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With

'結果の書き込み位置の確認。3行目以降の空欄に書き込む。
For i = 3 To 102

If Cells(i, 1) = "" Then
Exit For
End If

Next

'上記破線の左上に通し番号のラベルをつける

ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, PosiPix(1, 1) - 5, PosiPix(1, 2), 25, 20).Select

Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = i - 3
Selection.ShapeRange.IncrementTop -10
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 6

'通し番号
Cells(i, 1) = i - 3

'一回目の場合のみ、画像内のものさしを設定（定規、10円玉、たばこetc,なんでもいい）
If i = 3 Then
'ものさしの幅を入力（単位はない）
Cells(3, 3) = InputBox("Sizeを入力", "入力", "1")

End If

'ピクセル単位での2点間の距離をB列に記入
Cells(i, 2) = Sqr*1 ^ 2 + (PosiPix(1, 2) - PosiPix(2, 2)) ^ 2)
'ものさしの長さをもとに計算した2点間の距離をＣ列に記入
Cells(i, 3) = Cells(i, 2) / Cells(3, 2) * Cells(3, 3)

'初期状態にもどす。
Application.Cursor = xlDefault
state = 1

Case Else '1回目のクリック

state = 2

Application.Cursor = xlNorthwestArrow 'カーソルを指から矢印に変え

End Select

End Sub

Function GCPPixX() As Single
'カーソルのエクセル内でのX座標(Pixel)を返すファンクション。
Dim Pos As POINTAPI

GetCursorPos Pos
GCPPixX = (Pos.CPosix - ActiveWindow.PointsToScreenPixelsX(0)) / ActiveWindow.Zoom * 100 / 96 * 72

End Function

Function GCPPixY() As Single
'カーソルのエクセル内でのY座標(Pixel)を返すファンクション。
Dim Pos As POINTAPI

GetCursorPos Pos
GCPPixY = (Pos.Cposiy - ActiveWindow.PointsToScreenPixelsY(0)) / ActiveWindow.Zoom * 100 / 96 * 72

End Function

Function File選択(titlestr As String) As String
'ダイアログでファイルを選択し、選択されたファイルのパスを返すファンクション。
If titlestr = "" Then
titlestr = "ファイル選択"
End If

With Application.FileDialog(msoFileDialogFilePicker)
.Title = titlestr
If .Show = -1 Then 'アクションボタンがクリックされた
File選択 = .SelectedItems(1)
Else 'キャンセルボタンがクリックされた
File選択 = "CANCEL"
End If
End With

End Function

*1:PosiPix(1, 1) - PosiPix(2, 1