季節外れの蚊に悩まされていた。
蚊の嫌いな周波数を発生するソフトがあったことを思い出し、蚊の嫌がる周波数を調べて見た。
周波数を調べているうちに、他の動物の嫌がる周波数も分かってきた。
エクセルの作業中に蚊や他の動物達の邪魔をさせないと思い、いろんな周波数を発生するマクロを作成した。
途中、こんなボタンを押すことは無いんだろうなーと思いながらも片っぱしから登録した。
登録したのは蚊、ねずみ、ゴキブリ、猫＆犬、モグラ、鳩の計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の内臓スピーカが悪いのか？

白黒の写真から白色の面積率を求めることがある。
今まで、
(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をダウンロードして下さい。

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

'標準モジュール
'使用例　=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

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

'標準モジュール
'使用例　=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

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

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

たったこれだけで、５時間が２分以下に。はじめてＶＢＡを覚えてよかったと思った。

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

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

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