VB.NETで半透明フォーム上のラベルコントロールの背景を透過させたい

前提・実現したいこと

発生している問題・エラーメッセージ

UpdateLayerdWindowを利用して半透明フォームを作成しました。
同時にフォーム上のラベルコントロールの背景も透過させたいのですが実現方法がわかりません。
特にUpdateLayerdWindowを利用しなくても問題が解決できればと思いますので
ご回答いただけますと幸いです。

該当のソースコード

Imports System.Runtime.InteropServices

Public Class Form1
    Private img As Bitmap
    Private g As Graphics

#Region " UpdateLayerdWindow 関連 API "
    <DllImport("gdi32.dll", ExactSpelling:=True, SetLastError:=True)>
    Public Shared Function CreateCompatibleDC(ByVal hDC As IntPtr) As IntPtr
    End Function

    <DllImport("gdi32.dll", ExactSpelling:=True, SetLastError:=True)>
    Public Shared Function DeleteDC(ByVal hdc As IntPtr) As Boolean
    End Function

    <DllImport("gdi32.dll", ExactSpelling:=True, SetLastError:=True)>
    Private Shared Function DeleteObject(ByVal hObject As IntPtr) As Boolean
    End Function

    <DllImport("gdi32.dll", ExactSpelling:=True, SetLastError:=True)>
    Private Shared Function SelectObject(ByVal hDC As IntPtr, ByVal hObject As IntPtr) As IntPtr
    End Function

    <DllImport("user32.dll", ExactSpelling:=True, SetLastError:=True)>
    Private Shared Function GetDC(ByVal hWnd As IntPtr) As IntPtr
    End Function

    <DllImport("user32.dll", ExactSpelling:=True, SetLastError:=True)>
    Private Shared Function ReleaseDC(ByVal hWnd As IntPtr, ByVal hDC As IntPtr) As Integer
    End Function

    <DllImport("user32.dll", ExactSpelling:=True, SetLastError:=True)>
    Private Shared Function UpdateLayeredWindow(
        ByVal hwnd As IntPtr,
        ByVal hdcDst As IntPtr,
        <System.Runtime.InteropServices.In()>
        ByRef pptDst As Point,
        <System.Runtime.InteropServices.In()>
        ByRef psize As Size,
        ByVal hdcSrc As IntPtr,
        <System.Runtime.InteropServices.In()>
        ByRef pptSrc As Point,
        ByRef crKey As Integer,
        <System.Runtime.InteropServices.In()>
        ByRef pblend As BLENDFUNCTION,
        ByVal dwFlags As Integer
        ) As Boolean
    End Function

    <StructLayout(LayoutKind.Sequential, Pack:=1)>
    Private Structure BLENDFUNCTION
        Public BlendOp As Byte
        Public BlendFlags As Byte
        Public SourceConstantAlpha As Byte
        Public AlphaFormat As Byte
    End Structure

    Private Const WS_EX_LAYERED As Integer = &H80000    'レイヤードウィンドウ
    Private Const WS_BORDER As Integer = &H800000       '境界線を持つウィンドウを作成
    Private Const WS_THICKFRAME As Integer = &H40000    'サイズ変更境界を持つウィンドウを作成
    'ブレンドアクションの設定
    Private Const AC_SRC_ALPHA As Byte = 1  '転送元画像にアルファ値あり
    Private Const ULW_ALPHA As Integer = 2
#End Region

#Region " Form1にレイヤードウィンドウスタイルを適用 "
    Protected Overrides ReadOnly Property CreateParams() As CreateParams
        'CreateParamsの主なパブリックプロパティ
        '[ ExStyle    ] 拡張ウィンドウの外観とコントロールに適用する初期状態を取得または設定
        '[ Style      ] ウィンドウの外観とコントロールに適用する初期状態を取得または設定
        '[ Caption    ] コントロールの初期テキストを取得または設定
        '[ ClassName  ] コントロールの派生元の Windows クラスの名前を取得または設定
        '[ ClassStyle ] クラス スタイル値のビットごとの組み合わせを取得または設定
        '[ Param      ] コントロールの作成に必要な追加のパラメータ情報を取得または設定
        '[ Parent     ] コントロールの親を取得または設定
        Get
            Dim cp As CreateParams = MyBase.CreateParams
            cp.ExStyle = cp.ExStyle Or WS_EX_LAYERED
            Return cp
        End Get
    End Property
#End Region

#Region " フォームイベント "
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        '枠無しフォームを用意
        Me.FormBorderStyle = FormBorderStyle.None
        Me.ControlBox = False
        Me.MaximizeBox = False
        Me.MinimizeBox = False
        Me.Text = String.Empty
        Me.Left = 100
        Me.Top = 300

        img = New Bitmap(Me.Width, Me.Height)
        g = Graphics.FromImage(img)
        g.Clear(Color.FromArgb(100, Color.Black))   '黒で不透明度 = 100

        UpdateWindow()
    End Sub
#End Region

#Region " レイヤードウィンドウを更新 "
    Private Sub UpdateWindow()
        Dim hScreenDC As IntPtr = GetDC(IntPtr.Zero)            '画面全体に対応するDCのハンドルを取得
        Dim memoryDC As IntPtr = CreateCompatibleDC(hScreenDC)  'メモリDCを作成
        Dim hBitmap As IntPtr = IntPtr.Zero                     'ビットマップハンドルを初期化
        Dim hOldBitmap As IntPtr = IntPtr.Zero                  'ビットマップハンドルを初期化

        Try
            hBitmap = img.GetHbitmap(Color.Empty)               '[img]のビットマップハンドルを取得
            hOldBitmap = SelectObject(memoryDC, hBitmap)        'メモリDCに[img]を関連付ける

            ' BLENDFUNCTION 構造体を初期化 
            Dim blend As BLENDFUNCTION
            blend.BlendOp = 0                   'ブレンド操作
            blend.BlendFlags = 0                '常に0
            blend.SourceConstantAlpha = 255     'コピー元のビットマップ全体に適用するアルファ値 (0～255)
            blend.AlphaFormat = AC_SRC_ALPHA    'コピー元のビットマップがアルファ値を持つとき(AC_SRC_ALPHA)

            ' レイヤードウィンドウを更新
            ' 半透明用のメモリ上のフレームバッファを用意してその中にデータを書き込み、その結果をUpdateLayeredWindow関数で転送して画面に表示
            Dim r As Boolean = UpdateLayeredWindow(Me.Handle,       'レイヤードウィンドウのハンドル
                                                   hScreenDC,       '画面のDCのハンドル
                                                   Me.Location,     'レイヤードウィンドウの新しい画面位置
                                                   New Size(img.Width, img.Height), 'レイヤードウィンドウの新しいサイズ
                                                   memoryDC,        'レイヤードウィンドウを定義するサーフェスの DC のハンドル (CreateCompatibleDCで得られる)
                                                   New Point(0, 0), 'デバイスコンテキストにおけるレイヤの位置
                                                   0,               'レイヤードウィンドウを構成するときに使うカラーキーが入った COLORREF型
                                                   blend,           'レイヤードウィンドウを構成するときに使う透明度の値が入った TBLENDfunction型へのポインタ
                                                   ULW_ALPHA)       '★フラグ
        Finally
            ReleaseDC(IntPtr.Zero, hScreenDC)       'DC開放
            If hBitmap <> IntPtr.Zero Then
                SelectObject(memoryDC, hOldBitmap)  'メモリDCのビットマップを戻す
                DeleteObject(hBitmap)               'ビットマップハンドルを開放
            End If
            DeleteDC(memoryDC)                      'メモリDCを開放
        End Try
    End Sub
#End Region

End Class

試したこと

補足情報（FW/ツールのバージョンなど）

VB.NET（Visual Studio 2019）

YAmaGNZ

2020/11/18 12:39

提示されているソースですとフォーム全体を半透明化しているようですが、実際に求めているものも全体を半透明化し、そのフォームにあるコントロールも全て半透明化するのでしょうか？

hogetarou4012

2020/11/18 13:45

そうです。見た目は半透明フォームに直接文字を描画した感じです。直接文字を描画する事はできますが、都合上ラベルなどのコントロールを使用したいのです。

YAmaGNZ

2020/11/18 22:13

では、Labelにしなくてはいけない理由はなんなのでしょうか？

hogetarou4012

2020/11/19 00:09

説明が足りなくてすいません。やりたい事は文字テロップを滑らかにスクロールさせる事です。（背景は半透明で）半透明フォームに直接文字列を描画し、描画間隔毎に位置をずらして再描画させる事で実現できていますが、どうしても多少カクついてしまう事があります。（表示エリアが決まっているのでフォーム位置は固定しています）そこでラベルを移動させれば滑らかに見えるのではと思った次第です...

YAmaGNZ

2020/11/19 01:17

半透明ではない状態で文字を直接描画する場合はかくついて、Labelを移動する場合はかくつかないという状態なのでしょうか？想像ですが、文字を直接描画するかLabelにするかよりどのようにしてスクロールさせているのかのほうが重要な気がします。

hogetarou4012

2020/11/19 03:15

ラベルで実装してみましたがそれほど変わりませんね... おっしゃる通りスクロールの方法が問題なのかもしれません。現在、System.Timersを使用して15ミリ秒間隔で2ピクセル移動させています。滑らかに見える時もあればカクつく事もあり安定しません。最初の質問からずれてしまいましたが、解決策などご何か存知でしょうか？どうぞよろしくお願いします。

Zuishin

2020/11/19 04:43

15 ミリ秒が正確に取れていないんだと思います。 15 ミリ秒毎に 2 ピクセル動かすのではなく、1.5 秒で 200 ピクセル動かすとしてタイマーイベントごとに現在時刻を取得し、その時刻の時点で表示されるべき場所を計算してそこに移動させるのが良いと思います。そうすれば多少コマ落ちしても目立たずスムーズに移動しているように見えます。

hogetarou4012

2020/11/19 16:41

なるほど、そういうやり方もあるのですね。タイマー部分についてもう少しいろいろ試してみます。ありがとうございました。

行動規範の内容に同意します

回答1件

ベストアンサー

全体を半透明化したいだけなのであれば、UpdateLayerdWindowではなくForm.Opacityプロパティを設定してはどうですか？

とりあえずUpdateLayerdWindowを使用しない方法ですが
フォームを２つ用意します。
Form1は半透明にするフォーム、こちらには半透明として表示するものを配置します。
そしてOpacityプロパティを設定して半透明にします。

Form2は背景を単色（例えばColor.Black）とし、TransparencyKeyプロパティを利用してその単色を透明にするようにし。Form1をownerとしてForm1と同じ位置に表示します。

そうすれば

このような形で表示できます。

もし、上図のようにLabelの背景をFormの背景と同じではなく別の色とするのであれば、透過するフォームのほうにその背景の領域だけその色でなんらかの形で描画する形になります。

追記

タイマーの処理ですが

VBNET
1    Private t As Timers.Timer
2
3    Private Sub TimerStart()
4        t = New Timers.Timer(15)
5        AddHandler t.Elapsed, AddressOf Timer_Elapsed
6
7        t.Start()
8    End Sub
9
10    Private Sub Timer_Elapsed(sender As Object, e As EventArgs)
11        Static prevtime As DateTime = Now
12        Console.WriteLine($"{(Now - prevtime).TotalMilliseconds}ms")
13        prevtime = Now
14    End Sub
15

このような処理を実行してみれば分かるのですが、まれに間隔が30ms等長い時があります。
こういった時にかくつくように感じるのではないでしょうか。

VBNET
1Private Sub TaskStart()
2    Static prevtime As DateTime = Now
3    Task.Run(Sub()
4                    While True
5                        Console.WriteLine($"{(Now - prevtime).TotalMilliseconds}ms")
6                        prevtime = Now
7
8                        Threading.Thread.Sleep(15)
9                    End While
10                End Sub)
11End Sub