ユーザーフォームのやつ

2021年10月29日 20:25

自分だけ楽したい人のためのEXCEL VBA
ユーザーフォームのサイズ変更ができるようにする
2021/10/28 23:010
前の記事
次の記事
ホーム
今回もすぐに使えるプロシージャを紹介していきます。

今回は、ユーザーフォームのサイズ変更ができるようにするプロシージャを紹介します。

<引用元>
今回はほとんど下記サイトより引用し、一部改良しています。
https://vbabeginner.net/change-form-size-minimize-and-maximize/

改良点はユーザーフォームのサイズ変更時(Resize時)にコントロールや文字サイズが同じような比率で変更されるようになっている点です。

<実行サンプル>
https://drive.google.com/drive/folders/1RTh8BL8QfX8yHL-qxU4BUfcwsNVWbfWn?usp=sharing

<使い方>
実行サンプルで起動するユーザーフォームに登録してあるコードです。

ユーザーフォームのイベントプロシージャで
ActivateイベントにてSetFormEnableResizeプロシージャを実行します。
InitializeイベントにてInitializeFormResizeプロシージャをMe(自身のフォームオブジェクト)を渡して実行します。
ResizeイベントにてResizeFormプロシージャをMe(自身のフォームオブジェクト)を渡して実行します。

<コード解説>

技術1:ユーザーフォームがリサイズ可能にする。
ユーザーフォームのリサイズ設定は上記のサイトを参考にしてください。

技術2:各コントロール、文字サイズも追随してリサイズ
コントロールや文字サイズをユーザーフォームのサイズに対して変わらないように変更する方法となります。
言い換えるとユーザーフォームのサイズと各コントロールや文字のサイズ、位置関係の比率を常に一定となるようにしています。
今回は初期状態での各コントロールや文字サイズのユーザーフォームのサイズとの比率と、
ユーザーフォームをリサイズ前後のユーザーフォームのサイズを取得して、リサイズ後の各コントロールや文字サイズのユーザーフォームのサイズを変更する方法をとっています。
この処理にはPrivate変数を用いています。

またコントロールの種類によっては同じ処理を行うとエラーになったりする場合もあるので、場合分けの処理も必要になります。

<広告>
Excelでの自動化のサポートをココナラの方で請け負っています。
ご相談からでも構いませんので、気軽にご連絡ください。

<コード>

Option Explicit

'// Win32API用定数
Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_THICKFRAME = &H40000

'// Win32API参照宣言
'// 64bit版
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
'// 32bit版
#Else
            Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
            Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
            Private Declare Function GetActiveWindow Lib "user32" () As Long
#End If

Private PriIniWidth           As Double 'ユーザーフォームのリサイズ前の幅
Private PriIniHeight          As Double 'ユーザーフォームのリサイズ前の高さ
Private PriResizeCount        As Long   'ユーザーフォームのリサイズ回数
Private PriFontSizeRateList() As Double '各コントロールのフォントサイズ変更用の比率を格納

Public Sub SetFormEnableResize()
'参考：https://vbabeginner.net/change-form-size-minimize-and-maximize/
'ユーザーフォームのリサイズを可能にする
'ユーザーフォームのイベント(UserForm_Activate)で実行する
'↓をActivateイベントに貼り付けてコメント解除
'   Call SetFormEnableResize

'20211007
#If VBA7 And Win64 Then
    Dim hwnd As LongPtr  'ウインドウハンドル
    Dim style As LongPtr 'ウインドウスタイル
#Else
    Dim hwnd As Long  'ウインドウハンドル
    Dim style As Long 'ウインドウスタイル
#End If

    'ウインドウハンドル取得
    hwnd = GetActiveWindow()

    'ウインドウのスタイルを取得
    style = GetWindowLong(hwnd, GWL_STYLE)

    'ウインドウのスタイルにウインドウサイズ可変＋最小ボタン＋最大ボタンを追加
    style = style Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX

    'ウインドウのスタイルを再設定
    Call SetWindowLong(hwnd, GWL_STYLE, style)

End Sub

Public Sub InitializeFormResize(TargetForm As Object)
'ユーザーフォームのリサイズ用の初期設定
'ユーザーフォームのイベント(UserForm_Initialize)で実行する。
'↓をInitializeイベントに貼り付けてコメント解除
'   Call InitializeFormResize(Me)

'20211007

'引数
'TargetForm・・・対象とするユーザーフォーム/オブジェクト型

    PriIniHeight = TargetForm.Height '初期状態のユーザーフォームの高さ取得
    PriIniWidth = TargetForm.Width   '初期状態のユーザーフォームの幅取得
    PriResizeCount = 0               'リサイズの回数初期化

End Sub

Public Sub ResizeForm(TargetForm As Object, Optional FontSizeResize As Boolean = True)
'ユーザーフォームのコントロールをリサイズする
'ユーザーフォームのイベント(UserForm_Resize)で実行する
'↓をResizeイベントに貼り付けてコメント解除
'   Call ResizeForm(Me)

'20211007

'引数
'TargetForm      ・・・対象とするユーザーフォーム/オブジェクト型
'[FontSizeResize]・・・フォントサイズを変更するかどうか/Boolean型/デフォルトではサイズ変更する

    PriResizeCount = PriResizeCount + 1 'リサイズの回数+1

    Dim TmpControl    As MSForms.Control 'ユーザーフォーム内の各コントロール
    Dim NowFormHeight As Double
    Dim NowFormWidth  As Double          'サイズ変更後のユーザーフォームのサイズ
    Dim HeightRate    As Double
    Dim WidthRate     As Double          'サイズ変更によるサイズの比率変化
    Dim Top1          As Double
    Dim Left1         As Double
    Dim Height1       As Double
    Dim Width1        As Double
    Dim FontSize1     As Double          '変更前の各サイズ
    Dim Top2          As Double
    Dim Left2         As Double
    Dim Height2       As Double
    Dim Width2        As Double
    Dim FontSize2     As Double          '変更後の各サイズ

    NowFormHeight = TargetForm.Height         'リサイズ後のユーザーフォームの高さ取得
    NowFormWidth = TargetForm.Width           'リサイズ後のユーザーフォームの幅取得
    HeightRate = NowFormHeight / PriIniHeight 'リサイズ前後での高さ比率
    WidthRate = NowFormWidth / PriIniWidth    'リサイズ前後での幅比率

    Dim K As Long
    If PriResizeCount = 1 Then 'コントロールの数だけフォントサイズの比率の初期状態を保存しておく

        ReDim PriFontSizeRateList(1 To TargetForm.Controls.Count)

        K = 0
        For Each TmpControl In TargetForm.Controls '各コントロールのフォントサイズ/(高さ+幅)を取得
            K = K + 1

            FontSize1 = 0
            On Error Resume Next 'コントロールによってはフォントがない場合もあるのでその際のエラー回避
            FontSize1 = TmpControl.FontSize
            If FontSize1 <> 0 Then
                PriFontSizeRateList(K) = FontSize1 / (TmpControl.Height + TmpControl.Width)
            Else
                FontSize1 = TmpControl.Font.Size 'ツリービューやリストビューはこのプロパティ設定
                If FontSize1 <> 0 Then
                    PriFontSizeRateList(K) = FontSize1 / (TmpControl.Height + TmpControl.Width)
                End If
            End If
            On Error GoTo 0
        Next
    End If

    K = 0
    For Each TmpControl In TargetForm.Controls
        K = K + 1
        With TmpControl 'コントロールのリサイズ前の位置、サイズ取得
            Top1 = .Top
            Left1 = .Left
            Height1 = .Height
            Width1 = .Width
'            FontSize1 = .FontSize
        End With

        'コントロールのリサイズ後の位置、サイズ計算
        Top2 = Top1 * HeightRate
        Left2 = Left1 * WidthRate
        Height2 = Height1 * HeightRate
        Width2 = Width1 * WidthRate

        'コントロールのリサイズ後のフォントサイズ計算
        FontSize2 = (Height2 + Width2) * PriFontSizeRateList(K) 'フォントサイズは高さと幅に対する比率で設定

        With TmpControl 'コントロールのリサイズ後の位置、サイズ、フォントサイズ設定
            .Top = Top2
            .Left = Left2
            .Height = Height2
            .Width = Width2

            If FontSizeResize = True Then
                On Error Resume Next 'コントロールによってはフォントがない場合もあるのでその際のエラー回避
                .FontSize = FontSize2
                .Font.Size = FontSize2
                On Error GoTo 0
            End If
        End With

    Next

    '次のリサイズの際のために、現在のユーザーフォームの高さ、幅を取っておく
    PriIniHeight = NowFormHeight
    PriIniWidth = NowFormWidth

End Sub

view rawUserFormResize hosted with ❤ by GitHub

コメントを書く

コメント(0件)
「ツール紹介」カテゴリの最新記事
VBA開発強力支援ツール「階層化フォーム」の紹介
ExcelVBAでPCログを取得して残業時間自動集計
エクセルスピログラフ
カテゴリ
ツール紹介
タグ
VBA
LINEで更新通知を受け取る
前の記事
次の記事
ホーム
LINEで送るこのエントリーをはてなブックマークに追加
コメントを書く

読者ボタン
ブログリーダー
Feedly
趣味・創作一般カテゴリ人気ブログ
1
花組『元禄バロックロック』新着キャストボイスは柚香光&星風...
大好き宝塚☆のんびりつぶやきBl...
2
10月26日13時予約開始！ＭＧ 1/100 ターンエー...
シナウス。　 ~限定品薄在庫復活...
3
【ミニ四駆】ノーシステムの考え方をメインマシンに！➁
サブカル”ダディ”ガッテム日記
4
フィリップス電気シェーバー（ PT764/14 ）分解修理
モモンハン日記
5
ＬＩＴＳ　２２９
ニコリ系パズルの逆襲[弍]
もっとみる

編集部の「推し」
ボンネットが開閉するミニカーボンネットが開閉するミニカー
愛猫の腎不全発覚から5年経過
去年"サイズをミスった"服が…
「秋の表情を求めて in 秋田」
美味しくできた"サバ缶パスタ"
フランスの"ヴィンテージ家具"
芋の味が甘く、香りがいい焼酎
大量の古本を店に持ち込んだら
もっとみる

急上昇ブログ

UPほわわん子育て絵日記

UPおうちマニア

UPくららんち。～B型夫婦と猫２匹の日常～

UPつれさか　-徒然サッカー雑記-

UPちこえ official blog

UPひだまりマーチ

UPぱれちにっき

UPもっちのママ友トラブル・子育て漫画

UPHIROのおいしいおうちごはん日記

UP生活のメモ

UP☆まかりな☆のにこにこ漫画ブログ

UPSMILE BENTO

UP写真で魅力発掘　～暮らしのフォトダイアリー～

UPたれまゆ日和

UPざくろ❤倶楽部

UP幸の食べ痩せ食堂

UPコウノトリが二羽飛んできた

UPめめみズム！

UP海外の反応で英語の勉強

UP魚の4コマ
もっとみる

暮らしブログ速報

【自分を癒やす大切な時間】自分も周りも幸せにするために
The essence of life

【本】与えられ脳から、自分軸へ＊思いどおりの成果をだすには
MakeLife＋ゆとり時間

TAUPE
綺麗をひと匙～Illustrator...
絵日記
料理
暮らし
ペット
おすすめ連載

1500g未満の赤ちゃん
"極低出生体重児"だった、娘の誕生の物語。

イケメン彼氏は〇〇が大好き！？
オシャレで会話が面白い彼と1回目のデートで破局！そのわけは…？

箱入娘面屋人魚
江戸時代に作られた"ヘンテコな作品"を漫画でお届け！
もっとみる

ブログ
ランキング
ブログ速報
ブログリーダー
livedoor Blog
PCモード
トップへ
Powered by livedoor Blog

この記事が気に入ったらサポートをしてみませんか？