ユーザーフォームのサイズ変更 ③ 画像を張り付けてみる

先日はスピンボタンで、ユーザーフォームのサイズを段階的に変化させてみた。
infoment.hatenablog.com

今日はこのユーザーフォームに、画像を表示することに挑戦する。

もともと今回のネタは、画像の中身をユーザーフォームに表示したいというのが切っ掛けだった。そこで今回は、Imageコントロールで画像を表示してみよう。

画像は決め打ちで準備する。

Private Sub UserForm_Initialize()
    ' スピンボタンの最大値と最小値を設定。
    SpinButton1.Min = 1
    SpinButton1.Max = 6
    ' 初期値。
    SpinButton1.Value = 3
    
    ' 今回追加。
    Image1.Picture = LoadPicture("C:\Temp\Sample.jpg")
End Sub

イメージのサイズは、ユーザーフォームのサイズに追従して欲しい。そこで、イメージの左上を起点として、10ポイントずつ内側に収まるようにしてみる。

色々と数値を調整して、このようになった。

Private Sub SpinButton1_Change()
    Static Dict As Scripting.Dictionary
        If Dict Is Nothing Then
            Set Dict = Devisor(12)
        End If

    ' ユーザーフォームのサイズ変更。
    ' 高さは、高さの約71％（１／√２倍）とした。
    ' ※馴染みのあるＡサイズ（A3やA4など）の比率。
    UserForm1.Width = unit_width * Dict(SpinButton1.Value)
    UserForm1.Height = UserForm1.Width / 2 ^ 0.5
    
    ' 今回追加。
    With Image1
        .Width = UserForm1.Width - 30
        .Height = UserForm1.Height - 72
        .Top = 40
        .Left = 10
    End With
End Sub

テスト結果は、まずまずと言ったところか。

明日に続きます。

参考まで。

ユーザーフォームのサイズ変更 ② 画面のｎ分の１サイズ（約数を求める関数の利用）

先日はユーザーフォームのサイズを、スピンボタンで変更してみた。
infoment.hatenablog.com

今日は、その続きに挑戦する。

先日は、ユーザーフォームの単位サイズを決め（例 50）、その倍数で横幅を変化させた。しかしもしユーザーフォームを複数枚横に並べるならば、ぴったり画面に収まった方が気持ちいい。

そこでまず、単位サイズをアクティブな画面の十二分の一にしてみた。

Private Property Get unit_width() As Long
' ユーザーフォームの単位幅。
' スピンボタンを押すたびに、この値の倍数で
' ユーザーフォームの幅を変化させる。
    unit_width = ActiveWindow.Width / 12
End Property

単位サイズを12で割ったのは、ピッタリで様々なパターンに並べるため。
　

スピンボタンが一つずつ変化するごとに、12の約数を上下させたい。
そこで、指定した数値の指定番目の約数を求める関数を作成してみた。

' 約数を求める関数。
' 約数を求めたい関数を１から順に割り、
' 余りが０の値を約数として辞書に格納する。
' ※MicroSoft Scripting Runtime 参照済み。
Private Function Devisor(source_number As Long) As Scripting.Dictionary
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
    Dim i As Long
    Dim Counter As Long: Counter = 1
        For i = 1 To source_number
            If source_number Mod i = 0 Then
                Dict(Counter) = i
                Counter = Counter + 1
            End If
        Next
        Set Devisor = Dict
End Function

スピンボタンの上下に伴うイベントは、値のChangeイベントに集約。

Private Sub SpinButton1_Change()
    Static Dict As Scripting.Dictionary
        If Dict Is Nothing Then
            Set Dict = Devisor(12)
        End If

    ' ユーザーフォームのサイズ変更。
    ' 高さは、高さの約71％（１／√２倍）とした。
    ' ※馴染みのあるＡサイズ（A3やA4など）の比率。
    UserForm1.Width = unit_width * Dict(SpinButton1.Value)
    UserForm1.Height = UserForm1.Width / 2 ^ 0.5
End Sub

これにより、初期化部分も簡素化出来た。

Private Sub UserForm_Initialize()
    ' スピンボタンの最大値と最小値を設定。
    SpinButton1.Min = 1
    SpinButton1.Max = 6
    ' 初期値。
    SpinButton1.Value = 3
End Sub

早速、実験してみよう。

これで、使用環境に合わせてユーザーフォームのサイズを
変更できるようになった。

次回に続きます。

参考まで。

ユーザーフォームのサイズ変更 ～ スピンボタンで操作 ～

ユーザーフォームのサイズを、任意に変更したくなった。

ユーザーフォームの端っこを摘まんで、びよ～んとサイズ変更できると有難い。
しかし、そのような機能は無いようだ。

そこで、試しにスピンボタンを設けてみた。こんな感じだ。

' ユーザーフォームの単位高さ。
' スピンボタンを押すたびに、この値の倍数で
' ユーザーフォームの高さを変更させる。
Const unit_width As Long = 50

Private Sub ChangeFormSize()
    ' ユーザーフォームのサイズ変更。
    ' 幅は、高さの約140％（√２倍）とした。
    ' ※馴染みのあるＡサイズ（A3やA4など）の比率。
    UserForm1.Height = unit_width * SpinButton1.Value
    UserForm1.Width = UserForm1.Height * 2 ^ 0.5
End Sub

Private Sub SpinButton1_SpinDown()
    Call ChangeFormSize
End Sub

Private Sub SpinButton1_SpinUp()
    Call ChangeFormSize
End Sub

Private Sub UserForm_Initialize()
    ' スピンボタンの最大値と最小値を設定。
    SpinButton1.Min = 1
    SpinButton1.Max = 10
    ' 初期値。
    SpinButton1.Value = 5
    ' 初期値に合わせてユーザーフォームサイズ変更。
    Call ChangeFormSize
End Sub

動きとしては、こんな感じだ。

悪くないかも。明日に続きます。

参考まで。

With で New すると、Class を Initialize してくれる

先日、このような記事を書いた。
infoment.hatenablog.com

ところが一方で、 With ステートメントで New する場合は、ちゃんと Class を Initialize してくれる（最近知った）。（それにしても、なんて怪しい日本語）。

Sub test()
    With New Class1
        ' 何某かの処理。
    End With
End Sub

実際は、変数で受けた方が便利な場合が多いので、使う機会は少ないかもしれない。でも、覚えておいて損は無いと思う。

もう一つ最近の個人的流行が、With ステートメントによる変数の省略だ。
例えば、テーブルにレコードを一つ追加して、１列目に数字を入力する場合。

ここに「ばなな」を追加する時、つい最近まで、このように書いていた。

Sub test()
    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    Dim ListRow As ListRow
    Set ListRow = Tb.ListRows.Add
        ListRow.Range.Cells(1) = "ばなな"
End Sub

しかし今は、このように書くこともある（場合による）。

Sub test()
    With ActiveSheet.ListObjects(1).ListRows.Add
        .Range.Cells(1) = "ばなな"
    End With
End Sub

可読性（分かり易さ）を損なわない程度なら、これもありかな。

参考まで。

初めて仕事で書いたマクロ（失敗談）

「仕事で初めてマクロを書いたときのことを覚えていますか？」
というご質問をいただいた。そこで、一番古い記憶を辿ってみた。

「初めて」か否かは、定かでない。ただ、一番古い記憶がこちらだと思う。

数値を小数点第三位に四捨五入して、テキストファイルに書き出す。

工作機械で加工プログラムを作成するとき、プログラムをテキストファイルに書きＮＣ（数値制御装置）に取り込む場合がある。

この時（15年以上前）の或る事案では、加工時の刃物の軌跡が何某かの数式で定まっており、Excelで座標を計算していた。そして担当者から、書き出した連続するXY座標を、小数点第四位以下は邪魔なので切って貰えないかと頼まれた。

そこでマクロに挑戦したのが、一番古い記憶だと思う。

このような数値があるとする。

これを、例えばこのように書き出してみる。

Sub Test()
    Dim TextFile As String
        TextFile = "C:\Temp\TextFile.txt"
        Open TextFile For Output As #1
        
    Dim i As Long
        For i = 1 To 3
            Print #1, Cells(i, 1)
        Next
        
        Close #1
End Sub

結果、このようなテキストファイルが作成される。

そこで単純に、書式を下三桁にして書き出してみた。

だが、結果は同じだった。見た目を変えても中身は変わっていないため、当たり前と言えば当たり前のこと。しかし当時は知識も乏しく（無いに等しく）、ここ以上先に進めなかった。

これをもし今やるとしたら、どうだろう。こんな感じかな。

Sub Test()
    Dim TextFile As String
        TextFile = "C:\Temp\TextFile.txt"
        Open TextFile For Output As #1
        
    Dim i As Long
        For i = 1 To 3
            Print #1, WorksheetFunction.Round(Cells(i, 1), 3)
        Next
        
        Close #1
End Sub

書き出すとき、単純に四捨五入しただけ。こんなにも単純なことが、当時の私にはできなかった。15年前に戻って、自分に教えてあげたい（その他、あんなことや、こんなことも教えておきたい）。しかし、今となっては叶わないこと。

という訳で、↓セピア色っぽくしてみました。

参考まで。

特定のフォルダにあるExcelファイルを全部開き、各A1の値をコピーして一つのファイルに集約する

特定のフォルダにあるExcelファイルを全て開き、その中身を集約する場面があった。そこで昔を振り返りながら、わがマクロの変遷を辿ってみる。

例えば、↓ こんな感じでファイルが三つあるとする。

実際の場面では、毎回何個か分からないだろうが、とりあえず今回は三個とする。
それぞのシートのA1には、食べ物の名前が入力されている。

昔はとにかく、決め打ちだった。パスも固定で、一つずれれば手直しが必要。

Sub Test_1()
    Workbooks.Open ("C:\Temp\test1.xlsx")
    Range("A1").Copy
    ActiveWorkbook.Close
    
    Range("A1").PasteSpecial
    
    Workbooks.Open ("C:\Temp\test2.xlsx")
    Range("A1").Copy
    ActiveWorkbook.Close
    
    Range("A2").PasteSpecial
    
    Workbooks.Open ("C:\Temp\test3.xlsx")
    Range("A1").Copy
    ActiveWorkbook.Close
    
    Range("A3").PasteSpecial
End Sub

これを活かしつつ修正するとしたら、こんな感じかな。

Sub Test_1()
    Dim i As Long
        For i = 1 To 3
            Workbooks.Open ("C:\Temp\test" & i & ".xlsx")
            Range("A1").Copy
            ActiveWorkbook.Close
            
            Cells(i, 1).PasteSpecial
        Next
End Sub

しかし実際は、毎回こんな都合の良いファイル名であるはずもなく。

時が経ち、Dir関数を覚えた。定番の、Do ～ Loop との組み合わせだ。

Sub Test_2()
    Const FolderPath As String = "C:\Temp"
    Dim FileName As String
        FileName = Dir(FolderPath & "\*.xls*")
        
        Workbooks.Open (FolderPath & "\" & FileName)
        Range("A1").Copy
        ActiveWorkbook.Close False
        Range("A1").PasteSpecial
        
        FileName = Dir
        
        Do While FileName <> ""
            Workbooks.Open (FolderPath & "\" & FileName)
            Range("A1").Copy
            ActiveWorkbook.Close False
            Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial
            FileName = Dir
        Loop
End Sub

流石に各ファイルパスの決め打ちは無くなったものの、未だ全体的に野暮ったい。

そして更に時は流れ現在に至る。今ある知識で、贅の限りを尽くしたのがコチラ。

Sub Test_3()
    ' 画面更新の一時停止。
    ' ※ファイルの数だけ開いたり閉じたりするため。
    Application.ScreenUpdating = False
    
    ' ファイルが保存されたフォルダー。
    Const FolderPath As String = "C:\Temp"
    
    ' ファイル操作用。
    ' MicroSoft Scripting Runtime 参照済み。
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    
    ' 値格納用。
    Dim Dict As Scripting.Dictionary
    Set Dict = New Scripting.Dictionary
      
    Dim File As Scripting.File
    ' フォルダー内の各ファイルについて処理。
        For Each File In FSO.GetFolder(FolderPath).Files
        
        ' 拡張子がExcelのものであることを確認する。
        ' ※xls*にすることで、xls，xlsx，xlsm，xlsbの全てに対応。
            If FSO.GetExtensionName(File.Path) Like "xls*" Then
                
                ' リンクの更新要求を避けるため、UpdateLinksはFalseとする。
                ' 編集不要なため、読み取り専用（ReadOnly）で開く。
                With Workbooks.Open(FileName:=File.Path, _
                                    UpdateLinks:=False, _
                                    ReadOnly:=True)
                    
                    ' ファイルパスをキーに、Ａ１の値をアイテムとして辞書に登録。
                    Dict(File.Name) = Range("A1").Value
                    
                    ' 用が済んだファイルを閉じる。
                    .Close False
                End With
            End If
        Next
        
        ' 辞書のアイテムは配列なので、シートに一括貼り付けできる。
        Range("A1").Resize(UBound(Dict.Keys) + 1) = WorksheetFunction.Transpose(Dict.Items)

    ' 画面更新停止の解除。
    Application.ScreenUpdating = True
End Sub

でも実は、PowerQueryを用いれば、マクロ不使用でも同じことができるので、
本当はそれが一番スマートかも。

来年の今頃、同じテーマでもう一度検討してみると、自分の成長度合いが確認
できてよいかも。

参考まで。

RandArray関数っぽいユーザー定義関数で、重複不可の引数を追加

昨日は、RandArray関数っぽく振舞う、ユーザー定義関数を作ってみた。
infoment.hatenablog.com

これの使い処を考えるうち、思いついた。少し手を加えれば、ランダムな並び替えに使用できるのでは？ということで、やってみた。

ランダム並び替えといっても、実はたいしたことをしていない。
単に、ランダムな整数の重複を禁止しただけ。結果が、ランダムに並べ替えたように見えるだけだったりする。

Function DemiRandArray(r_max As Long, _
                       c_max As Long, _
                       dra_min As Long, _
                       dra_max As Long, _
                       integer_flag As Boolean, _
              Optional duplicate_flag As Boolean = False) As Variant

    ' duplicate_flagがTrueの場合、整数に限り値の重複を不可とする。
    
    ' ランダムに作成した値を格納するための配列。
    Dim arr() As Variant
    ReDim arr(1 To r_max, 1 To c_max)
    
    ' ループ変数：行。
    Dim r As Long
    ' ループ変数：列。
    Dim c As Long
    ' 重複不可の場合に使用する辞書。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' ランダムに作成した値を一旦格納するための変数。
    Dim temp As Double
        For r = 1 To r_max
            For c = 1 To c_max
                ' Trueの場合、整数のみとする。
                Select Case integer_flag
                    Case True
                        ' Trueの場合、重複不可とする。
                        Select Case duplicate_flag
                            Case True
                                Do
                                    temp = WorksheetFunction.RandBetween(dra_min, dra_max)
                                    If Dict.Exists(temp) = False Then
                                        arr(r, c) = temp
                                        ' キー情報の重複を確認したいだけなので、アイテム不問。
                                        ' なんでもよいので、今回は「1」とした。
                                        Dict(temp) = 1
                                        Exit Do
                                    End If
                                Loop
                            Case False
                                arr(r, c) = WorksheetFunction.RandBetween(dra_min, dra_max)
                        End Select
                    Case False
                        Dim myFlag As Boolean
                            myFlag = False
                        Do While myFlag = False
                            temp = Rnd * (dra_max + 1)
                            If dra_min <= temp And temp <= dra_max Then
                                arr(r, c) = temp
                                myFlag = True
                            End If
                        Loop
                End Select
            Next
        Next
                
        DemiRandArray = arr
End Function

それでは、１～７５までの数字を縦に並べてみよう。
まずは、重複可の場合。

Sub Test()
    Dim arr As Variant
        arr = DemiRandArray(75, 1, 1, 75, True)
        Range("A2").Resize(75) = arr
End Sub

ピボットテーブルで集計してみると、欠番が生じていることが分かる。

次いで、重複不可の場合。

Sub Test()
    Dim arr As Variant
        arr = DemiRandArray(75, 1, 1, 75, True, True)
        Range("A2").Resize(75) = arr
End Sub

１～７５までの数が、全て一つずつ生成されている。

どうやら、上手くいったようだ。

では、これで何をするかというと・・・ビンゴゲームかな。

参考まで。