MessageBoxCustom.vb

'Using this class only because High DPI is bugged on the default ones
Imports System.IO
Imports System.Media
Imports System.Runtime.InteropServices

Public Class MessageBoxCustom

    <DllImport("user32.dll")>
    Private Shared Function GetDC(hWnd As IntPtr) As IntPtr
    End Function

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

    <DllImport("gdi32.dll")>
    Private Shared Function GetDeviceCaps(hDC As IntPtr, nIndex As Integer) As Integer
    End Function

    Private Const LOGPIXELSX As Integer = 88

    Public Shared Function GetPrimaryMonitorDpi() As Integer
        Dim hDC = GetDC(IntPtr.Zero)  ' IntPtr.Zero = primary monitor
        Try
            Return GetDeviceCaps(hDC, LOGPIXELSX)
        Finally
            ReleaseDC(IntPtr.Zero, hDC)
        End Try
    End Function


    Public Shared Function Show(owner As IWin32Window, message As String, title As String, buttons As MessageBoxButtons,
                                Optional icon As MessageBoxIcon = Nothing, Optional dpi As Integer = 96,
                               Optional sound As String = "[none,beep,criticalStop,notifyAlt,asterisk,exclaim,wavName]",
                                Optional focus As String = "[ok/yes,no,cancel]", Optional textWidth As Integer = 400) As DialogResult

        Dim PrimDPI As Integer = GetPrimaryMonitorDpi()

        Dim sX As Single = dpi / 96
        Dim sX2 As Single = dpi / PrimDPI
        Dim sX3 As Single = PrimDPI / 96


        Dim mainFont As New Font("Microsoft Sans Seriff", 9.0F * sX2) 'When debugging scaling is a problem.  Not applying scaling outside of the debugger seems to fix it
        Dim butHeight As Integer = TextRenderer.MeasureText("A", mainFont).Height / sX

        Dim paddingCorrected As Single = 16 * sX3

        Using dlg As New Form()
            dlg.AutoScaleMode = AutoScaleMode.Dpi 'changing this setting to none probably does nothing


            dlg.Text = title
            dlg.FormBorderStyle = FormBorderStyle.FixedDialog
            dlg.StartPosition = FormStartPosition.CenterParent
            dlg.MinimizeBox = False
            dlg.MaximizeBox = False
            'dlg.AutoSize = True 'Should be left false otherwise it conflicts with automatic DPI change events
            'dlg.AutoSizeMode = AutoSizeMode.GrowAndShrink


            Dim layout As New TableLayoutPanel() With {
                .ColumnCount = 2,
                .RowCount = 2,
                .AutoSize = True,
                .AutoSizeMode = AutoSizeMode.GrowAndShrink,
                .Padding = New Padding(paddingCorrected),
                .Dock = DockStyle.Fill
            }
            layout.RowStyles.Add(New RowStyle(SizeType.AutoSize))
            layout.RowStyles.Add(New RowStyle(SizeType.AutoSize))

            ' Top row: icon (optional) + message
            Dim topPanel As New FlowLayoutPanel() With {
                .AutoSize = True,
                .AutoSizeMode = AutoSizeMode.GrowAndShrink,
                .FlowDirection = FlowDirection.LeftToRight,
                .Margin = New Padding(0, 0, 0, paddingCorrected)
            }


            Dim bmp As Bitmap = Nothing
            Select Case icon
                Case MessageBoxIcon.Error, MessageBoxIcon.Stop
                    bmp = GetScaledIcon(IDI_HAND, 64)'sysIcon = SystemIcons.Error
                Case MessageBoxIcon.Warning, MessageBoxIcon.Exclamation
                    bmp = GetScaledIcon(IDI_EXCLAMATION, 64)'sysIcon = SystemIcons.Warning
                Case MessageBoxIcon.Information, MessageBoxIcon.Asterisk
                    bmp = GetScaledIcon(IDI_INFORMATION, 64)'sysIcon = SystemIcons.Information
                Case MessageBoxIcon.Question
                    bmp = GetScaledIcon(IDI_QUESTION, 64) 'sysIcon = SystemIcons.Question
            End Select


            If bmp IsNot Nothing Then
                Dim pic As New PictureBox() With {
                     .Image = bmp,'resizedIcon.ToBitmap(),
                    .Margin = New Padding(0, 0, 12, 0),
                    .Width = 32 * sX3,
                    .Height = 32 * sX3,
                    .SizeMode = PictureBoxSizeMode.Zoom
                    }
                layout.Controls.Add(pic, 0, 0)
            End If

            Dim lbl As New Label() With {
                .Text = message,
                .AutoSize = True,
                .MaximumSize = New Size(textWidth * sX3, 0),
                .Font = mainFont
            }


            topPanel.Controls.Add(lbl)

            ' Bottom row: buttons
            Dim buttonPanel As New FlowLayoutPanel() With {
                .AutoSize = True,
                .AutoSizeMode = AutoSizeMode.GrowAndShrink,
                .FlowDirection = FlowDirection.RightToLeft,
                .Dock = DockStyle.Fill
            }

            Dim btnOk As Button, btnYes As Button, btnNo As Button, btnCancel As Button
            Select Case buttons
                Case MessageBoxButtons.OK
                    btnOk = New Button() With {.Text = "OK", .DialogResult = DialogResult.OK, .TabIndex = 1, .Font = mainFont}
                    buttonPanel.Controls.Add(btnOk)
                    dlg.AcceptButton = btnOk

                Case MessageBoxButtons.OKCancel
                    btnCancel = New Button() With {.Text = "Cancel", .DialogResult = DialogResult.Cancel, .TabIndex = 2, .Font = mainFont}
                    btnOk = New Button() With {.Text = "OK", .DialogResult = DialogResult.OK, .TabIndex = 1, .Font = mainFont}
                    buttonPanel.Controls.AddRange({btnCancel, btnOk})
                    dlg.AcceptButton = btnOk
                    dlg.CancelButton = btnCancel

                Case MessageBoxButtons.YesNo
                    btnNo = New Button() With {.Text = "No", .DialogResult = DialogResult.No, .TabIndex = 2, .Font = mainFont}
                    btnYes = New Button() With {.Text = "Yes", .DialogResult = DialogResult.Yes, .TabIndex = 1, .Font = mainFont}
                    buttonPanel.Controls.AddRange({btnNo, btnYes})
                    dlg.AcceptButton = btnYes
                    dlg.CancelButton = btnNo

                Case MessageBoxButtons.YesNoCancel
                    btnCancel = New Button() With {.Text = "Cancel", .DialogResult = DialogResult.Cancel, .TabIndex = 3, .Font = mainFont}
                    btnNo = New Button() With {.Text = "No", .DialogResult = DialogResult.No, .TabIndex = 2, .Font = mainFont}
                    btnYes = New Button() With {.Text = "Yes", .DialogResult = DialogResult.Yes, .TabIndex = 1, .Font = mainFont}
                    buttonPanel.Controls.AddRange({btnCancel, btnNo, btnYes})
                    dlg.AcceptButton = btnYes
                    dlg.CancelButton = btnCancel
            End Select

            Select Case focus
                Case "[ok/yes,no,cancel]", "ok/yes"
                    'already default focus
                Case "no"
                    If btnNo IsNot Nothing Then btnNo.TabIndex = 0
                Case "cancel"
                    If btnCancel IsNot Nothing Then btnCancel.TabIndex = 0
            End Select


            layout.Controls.Add(topPanel, 1, 0)
            layout.Controls.Add(buttonPanel, 1, 1)

            dlg.Controls.Add(layout)


            Dim refBut As Button
            For Each ctrl As Button In buttonPanel.Controls
                ctrl.Height = (butHeight + 8) * sX3
                ctrl.Width = ctrl.Width * sX3
                refBut = ctrl
            Next


            Dim totalWidth As Single = 0
            For Each ctrl As Control In topPanel.Controls
                totalWidth += ctrl.Width
            Next

            dlg.Width = (topPanel.Left + totalWidth) * sX2 + 80 * sX3

            dlg.Height = 100


            'The following manually triggers a dpi change event because Windows doesn't do one during spawn by default.
            Dim r As New RECT
            r.Left = dlg.Left : r.Right = dlg.Right : r.Top = dlg.Top : r.Bottom = dlg.Bottom

            Const WM_DPICHANGED As Integer = &H2E0
            Dim dpiWord As New IntPtr(dpi)
            SendMessage(dlg.Handle, WM_DPICHANGED, dpiWord, r)


            Select Case sound
                Case "[none,beep,criticalStop,notifyAlt,asterisk,exclaim,wavName]", "none"
                    'play none
                Case "beep"
                    Media.SystemSounds.Beep.Play()
                Case "error", "critical", "criticalStop"
                    Media.SystemSounds.Hand.Play()
                Case "notifyAlt"
                    PlayWindowsSound("Windows Notify System Generic")
                Case "asterisk"
                    Media.SystemSounds.Asterisk.Play() 'same as beep normally
                Case "exclaim", "exclamation"
                    Media.SystemSounds.Exclamation.Play() 'same as beep normally
                Case Else
                    PlayWindowsSound(sound)
            End Select

            AddHandler dlg.Shown, Sub(sender As Object, e As EventArgs)
                                      Dim pos As Point = dlg.PointToClient(refBut.PointToScreen(Point.Empty))
                                      dlg.Height = (pos.Y + refBut.Height + 30 * sX) + 20 * sX
                                  End Sub

            Return dlg.ShowDialog(owner)
        End Using
    End Function


    <StructLayout(LayoutKind.Sequential)>
    Private Structure RECT
        Public Left, Top, Right, Bottom As Integer
    End Structure


    <DllImport("user32.dll")>
    Private Shared Function SendMessage(hWnd As IntPtr, msg As Integer,
                                        wParam As IntPtr,
                                        ByRef lParam As RECT) As IntPtr
    End Function

    Private Shared Sub PlayWindowsSound(fileName As String, Optional waitForComplete As Boolean = False)

        Dim folderPath As String = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Media")

        ' Append .wav if no extension provided
        If String.IsNullOrEmpty(Path.GetExtension(fileName)) Then
            fileName &= ".wav"
        End If

        Dim wavPath As String = Path.Combine(folderPath, fileName)

        Using player As New SoundPlayer(wavPath)
            Try
                If waitForComplete Then
                    player.PlaySync()
                Else
                    player.Play()
                End If
            Catch ex As Exception
                Stop
            End Try

        End Using
    End Sub

    <DllImport("comctl32.dll", SetLastError:=True)>
    Private Shared Function LoadIconWithScaleDown(
    hInstance As IntPtr,
    iconName As IntPtr,
    cx As Integer,
    cy As Integer,
    ByRef hIcon As IntPtr) As Integer
    End Function

    <DllImport("user32.dll", SetLastError:=True)>
    Private Shared Function DestroyIcon(hIcon As IntPtr) As Boolean
    End Function

    Private Const IDI_EXCLAMATION As Integer = 32515
    Private Const IDI_HAND As Integer = 32513
    Private Const IDI_INFORMATION As Integer = 32516
    Private Const IDI_QUESTION As Integer = 32514

    Private Shared Function GetScaledIcon(iconId As Integer, size As Integer) As Bitmap
        Dim hIcon As IntPtr = IntPtr.Zero
        Try
            LoadIconWithScaleDown(IntPtr.Zero, New IntPtr(iconId), size, size, hIcon)
            If hIcon = IntPtr.Zero Then Return Nothing
            Using ico = Icon.FromHandle(hIcon)
                Dim bmp = New Bitmap(size, size)
                Using g = Graphics.FromImage(bmp)
                    g.InterpolationMode = Drawing2D.InterpolationMode.HighQualityBicubic
                    g.DrawIcon(ico, New Rectangle(0, 0, size, size))
                End Using
                Return bmp
            End Using
        Finally
            If hIcon <> IntPtr.Zero Then DestroyIcon(hIcon)
        End Try
    End Function


    ''' Returns a list of all .wav files available in the Windows\Media directory.
    Public Function GetAvailableWindowsMediaSounds() As List(Of String)
        Dim mediaPath As String = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Windows), "Media")
        Dim files As New List(Of String)

        If Directory.Exists(mediaPath) Then
            For Each f As String In Directory.GetFiles(mediaPath, "*.wav", SearchOption.AllDirectories)
                files.Add(Path.GetFileNameWithoutExtension(f))
            Next
        End If

        Return files
    End Function

End Class