白黒の写真から白色の面積率を求めることがある。
今まで、
(1)写真をスキャン(JPEG)
(2)JPEGをビットマップ(BMP)化
(3)2値化
(4)エクセルのマクロで面積率を求める
といった工程であった。
(2)から(4)は3つのアプリケーションを用いており、非常に操作性が悪かった。
そこで今回(2)から(4)をエクセルだけで出来るように(4)を大幅に改造した。
エクセルが扱えられる画像ファイル(JPEG,BMP,GIF,TIFF,etc)ならなんでもOK。
カラーを白黒に加工する必要もなし。
2値化の境界もエクセルからできる。
マクロの内容は
白黒化：図の書式設定-図-イメージコントロールの色→白黒
2値化の境界変更：イメージコントロールの明るさを変更
計算用ビットマップの作成：画像ファイルを一旦コピーすることで、ビットマップファイルにする。
クリップボードにあるビットマップをファイル化
ビットマップの解析：白色の点の個数をカウント
計算用ビットマップファイルの作成はエクセルの基本機能ではできず、APIの塊となった。
使用したAPIは次の通り。
GlobalLock
GlobalUnlock
GlobalSize
CreateFile
CloseHandle
WriteFile
MoveMemory
OpenClipboard
CloseClipboard
GetClipboardData
マクロは*HP*内のの面積率測定2です。
従来は面積測定もあります。
マクロはエクセル上でAlt+F11で見ることが出来ます。
グラフィックエディター等から、画像をコピーし、それをエクセルへ貼り付けると、ビットマップ形式で貼りつくため、ファイル容量が膨大となる。そこで、貼り付けた画像をJPEGにするマクロを作ってみた。
コードを実行すると、対象ファイルを選択し、ブック内の貼り付けた画像を、JPEGに変更し、ファイル名に(diet)をつけて保存します。
なお、グループ化した画像は対象外となります。JPEG形式からGIF形式にする場合は、コードの
ActiveSheet.PasteSpecial Format:="図 (JPEG)"
を
ActiveSheet.PasteSpecial Format:="図 (GIF)"
に変更するだけ。
Sub test()
fn = Application.GetOpenFilename("ファイル (*.xls),*.xls", , "対象のファイルを開いてください")
Application.ScreenUpdating = False
If fn <> False Then
Workbooks.Open Filename:=fn
For Each ws In ActiveWorkbook.Sheets
Sheets(ws.Name).Select
For Each ss In ActiveSheet.Shapes
If InStr(ss.Name, "Object") Then
ActiveSheet.Shapes(ss.Name).Select
x = Selection.ShapeRange.Left
y = Selection.ShapeRange.Top
Selection.ShapeRange.Line.Visible = msoFalse
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)"
Selection.ShapeRange.Left = x + 10
Selection.ShapeRange.Top = y + 10
End If
Next
Next
ff = Mid(fn, InStrRev(fn, "\") + 1): ff = Left(ff, InStrRev(ff, ".") - 1) & "(diet).xls"
ActiveWorkbook.SaveAs Filename:=Left(fn, InStrRev(fn, ".") - 1) & "(diet).xls"
Windows(ff).Close
End If
Application.ScreenUpdating = True
End Sub
コードの入力が大変な方は、*HP*の右下のpic_dietをダウンロードして下さい。
