2023/09/05(Tue) 19:59:32 編集(投稿者)
2023/09/05(Tue) 19:59:28 編集(投稿者)

■No35510に返信(本体は眼鏡さんの記事)

親の子コントロールの処理がまずかったので修正しています。

いつか作ろうと思って作ってなかったんですが、いい機会なのでカスタムコントロールを作ってみました。
(1) 背景に親コントロールを描画
親コントロールは子コントロールを除いて描画する（でないと自分が描画されてしまい、ループする）
描画は WM_PRINTCLIENT メッセージを送ることで行っています。

(2) 親の子コントロールを描画
親の子コントロールは、その子も描画するので DrawToBitmap で良い

Option Strict On
Imports System.Runtime.InteropServices

Public Class TransparentPictureBox
    Inherits PictureBox

    Protected Overrides Sub OnPaintBackground(pevent As PaintEventArgs)
        MyBase.OnPaintBackground(pevent)
        If Parent IsNot Nothing Then
            DrawParent(pevent.Graphics, Parent)
            Dim ctls = Parent.Controls
            Dim i = ctls.Count - 1
            While i >= 0
                Dim ctrl As Control = ctls(i)
                If ctrl Is Me Then Exit While
                If ctrl.Visible Then
                    DrawSameHierarchy(pevent.Graphics, ctrl)
                End If
                i -= 1
            End While
        End If
    End Sub

    Private Sub DrawParent(g As Graphics, ctrl As Control)
        Dim mapRect = MapRectangle(Me, Me.ClientRectangle, ctrl)
        Dim rect = Rectangle.Intersect(ctrl.ClientRectangle, mapRect)
        If rect.Width > 0 AndAlso rect.Height > 0 Then
            Using bmp As New Bitmap(ctrl.Width, ctrl.Height,
                                    Imaging.PixelFormat.Format32bppRgb)
                Using bmpG = Graphics.FromImage(bmp)
                    Dim hdc = bmpG.GetHdc()
                    Dim printParam = PRF_CLIENT Or PRF_ERASEBKGND
                    SendMessage(ctrl.Handle, WM_PRINTCLIENT,
                                hdc, New IntPtr(printParam))
                    bmpG.ReleaseHdc()
                End Using
                Dim drawRect = MapRectangle(ctrl, rect, Me)
                g.DrawImage(bmp, drawRect, rect, GraphicsUnit.Pixel)
            End Using
        End If
    End Sub

    Private Sub DrawSameHierarchy(g As Graphics, ctrl As Control)
        Dim mapRect = MapRectangle(Me, Me.ClientRectangle, Parent)
        Dim rect = Rectangle.Intersect(ctrl.Bounds, mapRect)
        If rect.Width > 0 AndAlso rect.Height > 0 Then
            Using bmp As New Bitmap(ctrl.Width, ctrl.Height,
                                    Imaging.PixelFormat.Format32bppRgb)
                ctrl.DrawToBitmap(bmp, New Rectangle(Point.Empty, ctrl.Size))
                Dim drawRect = MapRectangle(Parent, rect, Me)
                Dim clipRect = New Rectangle(
                                rect.Location - CType(ctrl.Location, Size), rect.Size)
                g.DrawImage(bmp, drawRect, clipRect, GraphicsUnit.Pixel)
            End Using
        End If
    End Sub

    Private Function MapRectangle(fromCtrl As Control,
                                  fromRect As Rectangle,
                                  toCtrl As Control) As Rectangle
        Dim rect As New RECT(fromRect)
        MapWindowPoints(fromCtrl.Handle, toCtrl.Handle, rect, 2)
        Return rect.ToRectangle()
    End Function

    Private Const WM_PRINTCLIENT = &H318
    Private Const PRF_CHECKVISIBLE = &H1,
                  PRF_NONCLIENT = &H2,
                  PRF_CLIENT = &H4,
                  PRF_ERASEBKGND = &H8,
                  PRF_CHILDREN = &H10

    <StructLayout(LayoutKind.Sequential)>
    Private Structure RECT
        Public Left, Top, Right, Bottom As Integer
        Public Sub New(r As Rectangle)
            Left = r.Left
            Top = r.Top
            Bottom = r.Bottom
            Right = r.Right
        End Sub
        Public Function ToRectangle() As Rectangle
            Return Rectangle.FromLTRB(Left, Top, Right, Bottom)
        End Function
    End Structure

    <DllImport("user32")>
    Private Shared Function MapWindowPoints(
                        hwndFrom As IntPtr, hwndTo As IntPtr,
                        ByRef RECT As RECT, cPoints As Integer) As Integer
    End Function

    <DllImport("user32", CharSet:=CharSet.Auto)>
    Private Shared Function SendMessage(
                        hwnd As IntPtr, msg As Integer,
                        wparam As IntPtr, lparam As IntPtr) As IntPtr
    End Function

End Class

2023/09/09(Sat) 11:50:38 編集(投稿者)

Windows 8 から子ウインドウがレイヤードウインドウになれるので、アプリケーションマニュフェストを追加して

      <!-- Windows 8 -->
      <!--<supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}" />-->

のコメントアウトを解除すると、簡単に透過できますね。

# GetWindowLong/SetWindowLong を使っているのは手抜きです。(長くなるので）
# プロセスが 64bit なら GetWindowLongPtr,SetWindowLongPtr を使うのが正式なやり方。
# 64bit で SetWindowLong を使うと成功しても戻り値がゼロになってしまいます。

Imports System.Runtime.InteropServices

Public Class Form1

    Private Const WS_EX_LAYERED = &H80000
    Private Const GWL_EXSTYLE = -20
    Private Enum LWA
        COLORKEY = &H1
        ALPHA = &H2
    End Enum

    Private Sub PictureBox_HandleCreated(sender As Object, e As EventArgs) _
                Handles PictureBox1.HandleCreated,
                        PictureBox2.HandleCreated
        Dim pic = DirectCast(sender, PictureBox)
        pic.Image = My.Resources.megane_hikaru_woman
        pic.SizeMode = PictureBoxSizeMode.Zoom
        pic.BackColor = Color.Gray
        Dim dwStyle = GetWindowLong(pic.Handle, GWL_EXSTYLE)
        dwStyle = dwStyle Or WS_EX_LAYERED
        SetWindowLong(pic.Handle, GWL_EXSTYLE, dwStyle)
        SetLayeredWindowAttributes(
                pic.Handle, ColorTranslator.ToWin32(pic.BackColor),
                0, LWA.COLORKEY)
    End Sub

    <DllImport("user32.dll")>
    Private Shared Function GetWindowLong(
                hWnd As IntPtr, nIndex As Integer) As Integer
    End Function

    <DllImport("user32.dll")>
    Private Shared Function SetWindowLong(
                hWnd As IntPtr, nIndex As Integer,
                dwNewLong As Integer) As Integer
    End Function

    <DllImport("user32.dll")>
    Private Shared Function SetLayeredWindowAttributes(
                hWnd As IntPtr, crKey As Integer,
                bAlpha As Byte, dwFlags As LWA) As Boolean
    End Function

End Class

透過画像のまわりに BackColor が残ってしまいますが、目立たない色を設定しておくといいです。