空腹おやじのログと備忘録

VBA（主にExcel）でいろいろな実験的な事とか、Linuxのコマンドとか設定とかについて忘れないように、あれこれと・・・

【VBA】Excelのユーザーフォームをフェードイン、フェードアウトさせてみた

VBA Excel プログラミング

はじめに

Windows では、Windows 2000 Professional 以降のバージョンで、ウインドウに対して、特定の拡張ウインドウスタイルを適用し、レイヤード ウィンドウ化することで、

  • アルファブレンドによる、ウィンドウの半透過状態
  • カラーキーによる、特定色部の透過

を行うことが出来るようになりました。

今回は、エクセルのユーザーフォームに対し、アルファブレンドを設定し、ユーザーフォームのフェードイン、フェードアウトを行ってみます。

Twitter に載せたやつを、少し修正したものです。

処理の概要

簡単に言えば、以下の通り。
ただし、その処理を行うために、いくつかの準備等は必要です。

  1. ユーザーフォームに対し、拡張スタイルを適用
  2. アルファブレンド値を徐々に変化させる。

使用するAPI

FindWindow

ユーザーフォームのウィンドウハンドルを取得します。

HWND FindWindowA(
  LPCSTR lpClassName,
  LPCSTR lpWindowName
);

今回は、手っ取り早く
lpClassNameには、vbNullString
lpWindowNameには、ユーザーフォームのCaptionを指定します。

docs.microsoft.com

GetWindowLongPtr

指定したウィンドウのスタイルを取得します。

LONG_PTR GetWindowLongPtrA(
  HWND hWnd,
  int  nIndex
);

hWndには、FindWindowで取得した、ユーザーフォームのウインドウハンドルを指定します。
nIndexには、GWL_EXSTYLE を指定することで、ユーザーフォームに設定されている拡張ウィンドウスタイルを取得することができます。

SetWindowLongPtrA

指定したウィンドウに、スタイルを設定します。

LONG_PTR SetWindowLongPtrA(
  HWND     hWnd,
  int      nIndex,
  LONG_PTR dwNewLong
);

dwNewLong に、「GetWindowLongPtr で取得した拡張ウィンドウスタイルに対し、WS_EX_LAYEREDを追加した値を設定」することで、レイヤードウィンドウとすることができます。

SetLayeredWindowAttributes

今回の主役です。
ウィンドウの不透明度を設定します。
今回は使用しませんが、指定した色を透過させる事もできます。

BOOL SetLayeredWindowAttributes(
  HWND     hwnd,
  COLORREF crKey,
  BYTE     bAlpha,
  DWORD    dwFlags
);

crKeyには、レイヤードウィンドウを合成するときに使われる透明色キーを指定します。

bAlphaには、レイヤード ウィンドウの不透明度を表現するために使用されるアルファ値を指定します。
値は、0 から 255 の範囲で、0を指定すると、ウィンドウは完全に透明になり、255を指定すると、ウィンドウは不透明になります。

dwFlagsには、LWA_ALPHA 、LWA_COLORKEY のいずれかひとつ、または両方を指定できます。
LWA_COLORKEY を指定すると、透過させる色の指定が有効になります。
LWA_ALPHA を指定すると、ウィンドウの不透明度の指定が有効になります。

拡張ウィンドウスタイル

拡張ウィンドウスタイルには、多数のスタイルがあり、今回はその中から、WS_EX_LAYERED を使用します。
docs.microsoft.com

コード

事前準備

予め、frmFade というユーザーフォームを作っておき、
Caption に、FadeForm という文字列を設定しておきます。

標準モジュール

掲載しているのは、64bit版のコードです。

32bit版で使用する場合には、いくつかの修正が必要です。
32bit環境がないので、未確認ですが、最低でも以下の修正が必要と思われます。

  • Declare の PtrSafe 削除
  • GetWindowLongPtr ==> GetWindowLong
  • GetWindowLongPtr のreturn LongPtr ==> Long
  • SetWindowLongPtr ==>SetWindowLong
  • SetWindowLongPtr の dwNewLong の型 LongPtr ==> Long
  • hwnd の型 LongPtr ==> Long
  • lExStyle の型 LongPtr ==> Long
Option Explicit

Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1&
Private Const LWA_ALPHA = &H2&
Private Const GWL_EXSTYLE = -20&

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
       (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr

Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
       (ByVal hwnd As LongPtr, _
        ByVal nIndex As Long) As LongPtr

Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
       (ByVal hwnd As LongPtr, _
        ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr

Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _
       (ByVal hwnd As LongPtr, _
        ByVal crKey As Long, _
        ByVal bAlpha As Long, _
        ByVal dwFlags As Long) As Long

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)


Public Sub showForm()

    Dim f           As frmFade
    Dim hwnd        As LongPtr
    Dim lExStyle    As LongPtr
    Dim lResult     As Long
    Dim i       As Long

    Set f = frmFade

    'いきなり f.Show とすると、表示されてしまうので、Load するだけ
    Load f

    'タイトルを使って、ウィンドウハンドルを取得する
    hwnd = FindWindow(vbNullString, "FadeForm")

    lExStyle = GetWindowLongPtr(hwnd, GWL_EXSTYLE)

    If (lExStyle And WS_EX_LAYERED) = 0 Then
        'WS_EX_LAYEREDが未設定なら、拡張スタイルに、WS_EX_LAYERED を付与する
        lExStyle = lExStyle Or WS_EX_LAYERED

        Call SetWindowLongPtr(hwnd, GWL_EXSTYLE, lExStyle)
    End If

    '初期は､完全透過状態で表示させる
    Call SetLayeredWindowAttributes(hwnd, 0, 0, LWA_ALPHA)

    f.Show

    For i = 5 To 255 Step 5
        '不透明度を、上げていく
        Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA)

        DoEvents

        Call Sleep(40)
    Next i

    Call Sleep(1000)

    For i = 255 To 0 Step -5
        '不透明度を、下げていく
        Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA)

        DoEvents

        Call Sleep(40)
    Next i

    Unload f

    Set f = Nothing

End Sub

実行サンプル

f:id:Z1000S:20200514211257g:plain

何かのネタに使えるようなら使ってみて下さい。