エクセラのEXCEL
表計算ソフトEXCELでゲーム等を作っています。ゲーム等の作成状況を紹介。
BEEPの有効活用?

季節外れの蚊に悩まされていた。
蚊の嫌いな周波数を発生するソフトがあったことを思い出し、蚊の嫌がる周波数を調べて見た。
周波数を調べているうちに、他の動物の嫌がる周波数も分かってきた。
エクセルの作業中に蚊や他の動物達の邪魔をさせないと思い、いろんな周波数を発生するマクロを作成した。
途中、こんなボタンを押すことは無いんだろうなーと思いながらも片っぱしから登録した。
登録したのは蚊、ねずみ、ゴキブリ、猫&犬、モグラ、鳩の計6種類。
とりあえず周波数の発生時間は1000msとしているので、もっと長いほうが良いのならbeepの最後の数字を増やして下さい。
効果の確認はまだなので、効果を確認できた人は是非メールを下さい(笑)。


Declare Function beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long

Sub mosquito() '蚊
    beep Rnd * 3000 + 6000, 1000
End Sub

Sub rat() 'ねずみ
    beep Rnd * 30000 + 30000, 1000
End Sub

Sub cockroach() 'ゴキブリ
    beep Rnd * 3000 + 22000, 1000
End Sub

Sub cat_and_dog() '猫、犬
    beep Rnd * 5000 + 18000, 1000
End Sub

Sub mole() 'モグラ
    beep Rnd * 70 + 280, 1000
End Sub

Sub pigeon() '鳩
    beep Rnd * 10000 + 20000, 1000
End Sub

End Sub



人間が聞くことが出来る音波の周波数は20~20,000Hzであるが、beepで周波数を変えて聞いてみたところ36~13,750Hzしか聞こえなかった。私の耳が悪いのか、それともPCの内臓スピーカが悪いのか?

テーマ: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 - ジャンル:コンピュータ

再計算可能なセル変更関数

先日の関数を再計算にも対応させた。
あまりすっきりしたコードではないけど、名前定義を利用して、関数もどきの再計算をさせている。


'標準モジュール
'使用例 =rotate(対象のセル範囲,回転角) 回転角は-90~90
Function rotate(a As Range, b)
    rotate = a.Address & "," & b
End Function


'シートモジュール
Private Sub Worksheet_Calculate()
    Dim a As Variant
    For Each n In ActiveWorkbook.Names
        If n.Name Like "rotate_*" Then
            f = Range(n.Name).Formula
            If f Like "*rotate(*,*)*" Then
                a = Split(Range(n.Name), ",")
                Range(a(0)).Orientation = a(1)
            End If
        End If
    Next
End Sub


Private Sub Worksheet_Change(ByVal target As Range)
    Dim a As Variant
    For Each ta In target
        f = ta.Formula
        If f Like "*rotate(*,*)*" Then
            a = Split(ta, ",")  'a(0)は対象のセル a(1)は回転角
            Range(a(0)).Orientation = a(1)
            ActiveWorkbook.Names.Add Name:="rotate_" & Replace(ta.Address, "$", ""), RefersTo:="=" & ta.Address
        End If
    Next
End Sub

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

ユーザー定義関数でセルの内容を変更

関数でセルの内容を変更することはできませんが、以前、ユーザー定義関数(?)で強引にセルの内容を変更したことがあります。
次の例は、特定のセルの文字を回転させる関数(?)です。
なお再計算時には反映されません。

'標準モジュール
'使用例 =rotate(対象のセル範囲,回転角) 回転角は-90~90
Function rotate(a As Range, b As Long)
    rotate = a.Address & "," & b
End Function


'シートモジュール
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim a As Variant
    For Each ta In Target
        f = ta.Formula
        If f Like "*rotate(*,*)*" Then
            a = Split(ta, ",")  'a(0)は対象のセル a(1)は回転角
            Range(a(0)).Orientation = a(1)
        End If
    Next
End Sub

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

クイズ・ドレミファドン!
APIのBEEPを使うと、EXCELで音楽を流すことができます。
果たして何の曲が流れてくるでしょうか?
やり方のわからない人は、メール下さい。

Declare Function beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub sound()
Dim a()
a = [{32,5,0,2,24,2,32,2,40,2,48,2,40,2,0,2,32,2,36,2,0,2,36,2,36,2,0,2,27,5,0,1,36,2,32,2,0,2,30,2,32,5,0,2,24,2,32,2,40,2,48,2,40,2,0,2,32,2,34,2,0,2,34,2,34,2,0,2,32,5}]
For i = 1 To UBound(a) Step 2
If a(i) = 0 Then
Sleep a(i + 1) * 80
Else
beep a(i) * 10, a(i + 1) * 80
End If
Next
End Sub
はじめて自分のために

よく他の人のためにEXCELのマクロを作っていたが、今回たぶんはじめて自分のためにマクロを作った。
内容は、EXCELファイルが300個あり、その中の特定のデータを抜き取り、ひとつのファイルにするものだった。
300個をマクロを使わずに行うと、5時間は掛かったと思う。


Sub test()
 af = ActiveWorkbook.Name
 sr = Range("A65535").End(xlUp).Row + 1
 Set fs = Application.FileSearch
 FileToOpen = Application.GetOpenFilename("ファイル (*.xls),*.xls", , "目的のフォルダーを開いてください")
 If FileToOpen <> False Then
  Application.ScreenUpdating = False
  With fs
   .LookIn = Left(FileToOpen, InStrRev(FileToOpen, "\"))
   .SearchSubFolders = False: .Filename = "*.xls"
   If .Execute() > 0 Then
    For i = 1 To .FoundFiles.Count
     Workbooks.Open Filename:=.FoundFiles(i)
     With Workbooks(af).Worksheets(1)
途中省略
      Range(Cells(j, 1), Cells(j, 25)).Copy (.Cells(sr, 1))
途中省略
    Windows(Mid(.FoundFiles(i), InStrRev(.FoundFiles(i), "\") + 1)).Close
     End With     
    Next
   End If
  End With    
 End If
End Sub


たったこれだけで、5時間が2分以下に。はじめてVBAを覚えてよかったと思った。


そうそう、ブログの更新だけでなく、ゲーム作りも忘れていた。

無駄なことをやっていた(その2)

グラフ編
以前、データの無いところを補完して線を結ぶ方法を知らなかったとき
Function y(x1, y1, x2, y2, x)
    y = (y1 - y2) / (x1 - x2) * (x - x1) + y1
End Function
と中学生のとき?に習った2点間を通る直線の式を関数にしていた。
その後、わざわざ関数を作らなくてもForecastで計算できることを知った。
FORECAST(x, 既知のy, 既知のx)


さらにその後、わざわざ関数を使わなくても、データを補完して線を引いてくれる
機能があることを知った。
ツール-オプション-グラフ-補完してプロットする

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

文字(式)の計算
セルに計算式を文字として入力してあり(例えば 1+1)、
この部分を計算したい場合があった。
どのようにして計算すればよいのか調べて見ると
Evaluateを使えば計算できることが分かった。
Function calc(a)
    calc = Evaluate(a)
End Function
どこかのセルで =calc(計算したいセル)で計算可能。
最近、エクセルで出来ないものはないような気がしてきた。

テーマ:プログラミング - ジャンル:コンピュータ

がんばれ日本
子供達が寝て、VBAゲームプログラミングのチャンスと、22時からPCに向かう。しかし、サッカークロアチア戦が気になって、キーボードに手が行かなかった。前半戦終了でこれから後半戦。今日はPCはやめておこう。

テーマ:日記 - ジャンル:日記

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