エクセラのEXCEL
表計算ソフトEXCELでゲーム等を作っています。ゲーム等の作成状況を紹介。
面積率測定

白黒の写真から白色の面積率を求めることがある。
今まで、
(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で見ることが出来ます。

スポンサーサイト

テーマ:EXCEL - ジャンル:コンピュータ

ダイエット

グラフィックエディター等から、画像をコピーし、それをエクセルへ貼り付けると、ビットマップ形式で貼りつくため、ファイル容量が膨大となる。そこで、貼り付けた画像を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をダウンロードして下さい。

テーマ:EXCEL - ジャンル:コンピュータ

copyright © 2005 エクセラのEXCEL all rights reserved.
Powered by FC2ブログ.