Here Is A Customized Msgbox VBA Example

Here is an example of a customized VBA Msgbox.

We giving some richtext and customizable flair to the rather ordinary message box.

The following code provided with the code after the screenshot, is going to provide you with the
ability to really make the ordinary message box shine!

Sub MsgboxVBAExamples()
    Dialog.Box "VBAHowTo.com is your source for great VBA helps!", vbInformation, "Customized Message Box"
End Sub

This is an plain text dialog form.

You can also do rich text with this:

Here is the code:

Sub MsgboxVBAExamples_RichText()

    Dim strHideColor As String
    Dim strText As String
    Dim intUserAnswer As Integer
    
    strHideColor = "#E3EFFF"

    strText = strTagCenter & "

asdfasdfasfasfdasfasfassdfgsdgsddfghdfghdhasdfaszxvczcxrrrrrrrrrrrrfasfasdfsf

” ‘here you can use HTML tags to format your text box. intUserAnswer = Dialog.RichBox(strText, vbYesNo + vbInformation, “Customized Message Box”) Select Case intUserAnswer Case vbYes Dialog.Box “Yes, I agree” Case vbNo Dialog.Box “No they’re not” End Select End Sub

Here is what the ordinary form looks like:

…and here is the code behind the form for both message boxes:

'_______________________________________________________________________________________
'
' TYPE      : VBA Document Form_MsgBoxDialog
' AUTHOR    : LoeblCom Services
' DATE      : 2018
'
' PURPOSE   :
'_______________________________________________________________________________________

Option Compare Database
Option Explicit


'==============================================================================
' API and utiities delarations
'==============================================================================

Private Const INVALID_FILENAME_CHARS = "/\:*?<>""|"
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const WU_LOGPIXELSX = 88
Private Const WU_LOGPIXELSY = 90
'Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
'Private Const SW_SHOWMINIMIZED = 2
'Private Const SW_SHOWMAXIMIZED = 3
'Private Const SW_SHOW = 5

Private Const RES_BT_OK = 800
Private Const RES_BT_Cancel = 801
Private Const RES_BT_Abort = 802
Private Const RES_BT_Retry = 803
Private Const RES_BT_Ignore = 804
Private Const RES_BT_Yes = 805
Private Const RES_BT_No = 806
'Private Const RES_BT_Close = 807
'Private Const RES_BT_Help = 808
'Private Const RES_BT_TryAgain = 809
'Private Const RES_BT_continue = 810

Private Type RECT
   x1 As Long
   y1 As Long
   x2 As Long
   y2 As Long
End Type

Private Declare PtrSafe Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As Long, rectangle As RECT) As Boolean
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLib As Long) As Long 'BOOL
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal strFilePath As String) As Long
Private Declare PtrSafe Function LoadString Lib "user32" Alias "LoadStringA" (ByVal hLib As Long, ByVal ResourceID As Long, ByVal lpBuffer As String, ByVal nBufferSize As Long) As Long
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'==============================================================================
' Constants and internal fields
'==============================================================================
Private m_Buttons As VbMsgBoxStyle
Private m_Title As String
Private m_Prompt As String
Private m_ButtonDelay As Long
Private m_IsRichText As Boolean
Private m_Result As VbMsgBoxResult
Private m_PlaintextPrompt  As String
Private m_SavedTextFileFolder As String
Private m_AllowBeep As Boolean

'-----------------------------------------------------------------------------
' Get the dialog Result
'-----------------------------------------------------------------------------
Public Property Get Result() As VbMsgBoxResult
    Result = m_Result
End Property

'-----------------------------------------------------------------------------
' Get/Set the dialog Buttons and Style
'-----------------------------------------------------------------------------
Public Property Get Buttons() As VbMsgBoxStyle
    Buttons = m_Buttons
End Property

Public Property Let Buttons(btn As VbMsgBoxStyle)
    m_Buttons = btn
End Property

'-----------------------------------------------------------------------------
' Get/Set the dialog Prompt message
'-----------------------------------------------------------------------------
Public Property Get Prompt() As String
    Prompt = m_Prompt
End Property

Public Property Let Prompt(Message As String)
    m_Prompt = Message
End Property

'-----------------------------------------------------------------------------
' Get/Set where the text file should be saved when the user clicks the save message buttons
'-----------------------------------------------------------------------------
Public Property Get SavedTextFileFolder() As String
    SavedTextFileFolder = m_SavedTextFileFolder
End Property

Public Property Let SavedTextFileFolder(folder As String)
    m_SavedTextFileFolder = folder
End Property

'-----------------------------------------------------------------------------
' Get/Set the dialog Prompt message
'-----------------------------------------------------------------------------
Public Property Get ButtonDelay() As Long
    ButtonDelay = m_ButtonDelay
End Property

Public Property Let ButtonDelay(delay As Long)
    If delay < 0 Then delay = 0
    m_ButtonDelay = delay
End Property

'-----------------------------------------------------------------------------
' Get/Set whether Prompt is normal text or RichText (HTML)
'-----------------------------------------------------------------------------
Public Property Get IsRichText() As Boolean
    IsRichText = m_IsRichText
End Property

Public Property Let IsRichText(isrich As Boolean)
    m_IsRichText = isrich
End Property

'-----------------------------------------------------------------------------
' Get/Set whether we should play beeps or not
'-----------------------------------------------------------------------------
Public Property Get AllowBeep() As Boolean
    AllowBeep = m_AllowBeep
End Property

Public Property Let AllowBeep(allow As Boolean)
    m_AllowBeep = allow
End Property


'-----------------------------------------------------------------------------
' Get/Set the dialog title
'-----------------------------------------------------------------------------
Public Property Get Title() As String
    Title = m_Title
End Property

Public Property Let Title(caption As String)
    m_Title = caption
End Property

'==============================================================================
' Dialog Box implementation
'==============================================================================

'-----------------------------------------------------------------------------
' Open Form Event
'-----------------------------------------------------------------------------
Private Sub Form_Open(Cancel As Integer)
    txtMessage.BorderStyle = 0 'no border by default
    txtMessage.ScrollBars = 0 ' No scrollbar by default
    m_Result = 0
    m_IsRichText = False
    m_SavedTextFileFolder = CurrentProject.Path & "\"
    m_Buttons = (vbOKOnly + vbCritical)
    m_ButtonDelay = 2
End Sub


'-----------------------------------------------------------------------------
'  Show the form Modally
'-----------------------------------------------------------------------------
Public Function ShowModal() As VbMsgBoxResult
    caption = m_Title & " "
    TimerInterval = m_ButtonDelay * 1000
    If TimerInterval = 0 Then Form_Timer
    
    ' To size the textbox we will need to use the raw text data
    If m_IsRichText Then
        txtMessage.TextFormat = acTextFormatHTMLRichText
        m_Prompt = Replace(m_Prompt, "\n", "<br/>")
        m_PlaintextPrompt = Application.PlainText(m_Prompt)
    Else
        txtMessage.TextFormat = acTextFormatPlain
        m_Prompt = Replace(m_Prompt, "\n", vbCrLf)
        m_PlaintextPrompt = m_Prompt
    End If

    ' Initialise the buttons to show
    SetUpButtons
    
    ' Calulate the proper dimensions of the textbox and the form
    Redimension
    
    ' Make the form visible
    SetFocus
    
    ' Beep - The value passed to MessageBeep correspondonds to the style of the
    ' icon to be displayed and is encoded into the high nibble of the LSB
    If m_AllowBeep Then
        MessageBeep Buttons And &H70
    End If
    
    ' Wait until the form becomes hidden (user clicked a button)
    On Error GoTo Forced_Closed
    m_Result = -1
    Do While m_Result = -1
        DoEvents
        Sleep 50
    Loop
    
    ' Return the result
Forced_Closed:
    ShowModal = m_Result
End Function

'-----------------------------------------------------------------------------
'  Setup the buttons
'-----------------------------------------------------------------------------
Private Sub SetUpButtons()
    ' Detect which icon to display
    If (m_Buttons And vbExclamation) = vbExclamation Then
        imgQuestion.visible = False
        imgInformation.visible = False
        imgCritical.visible = False
        imgExclamation.visible = True
    ElseIf (m_Buttons And vbQuestion) = vbQuestion Then
        imgCritical.visible = False
        imgExclamation.visible = False
        imgInformation.visible = False
        imgQuestion.visible = True
    ElseIf (m_Buttons And vbCritical) = vbCritical Then
        imgExclamation.visible = False
        imgQuestion.visible = False
        imgInformation.visible = False
        imgCritical.visible = True
    Else
        imgQuestion.visible = False
        imgCritical.visible = False
        imgExclamation.visible = False
        imgInformation.visible = True
    End If

    ' Detect which buttons to display
    If (m_Buttons And vbRetryCancel) = vbRetryCancel Then
        bt3.visible = False
        bt2.visible = True
        bt2.Tag = vbRetry
        bt2.caption = GetUser32ResourceString(RES_BT_Retry)
        bt1.visible = True
        bt1.Tag = vbCancel
        bt1.caption = GetUser32ResourceString(RES_BT_Cancel)
        bt1.Cancel = True
    ElseIf (m_Buttons And vbYesNo) = vbYesNo Then
        bt3.visible = False
        bt2.visible = True
        bt2.Tag = vbYes
        bt2.caption = GetUser32ResourceString(RES_BT_Yes)
        bt1.visible = True
        bt1.Tag = vbNo
        bt1.caption = GetUser32ResourceString(RES_BT_No)
        bt1.Cancel = True
    ElseIf (m_Buttons And vbYesNoCancel) = vbYesNoCancel Then
        bt3.visible = True
        bt3.Tag = vbYes
        bt3.caption = GetUser32ResourceString(RES_BT_Yes)
        bt2.visible = True
        bt2.Tag = vbNo
        bt2.caption = GetUser32ResourceString(RES_BT_No)
        bt1.visible = True
        bt1.Tag = vbCancel
        bt1.caption = GetUser32ResourceString(RES_BT_Cancel)
        bt1.Cancel = True
    ElseIf (m_Buttons And vbAbortRetryIgnore) = vbAbortRetryIgnore Then
        bt3.visible = True
        bt3.Tag = vbAbort
        bt3.caption = GetUser32ResourceString(RES_BT_Abort)
        bt2.visible = True
        bt2.Tag = vbRetry
        bt2.caption = GetUser32ResourceString(RES_BT_Retry)
        bt1.visible = True
        bt1.Tag = vbIgnore
        bt1.caption = GetUser32ResourceString(RES_BT_Ignore)
        bt1.Cancel = True
    ElseIf (m_Buttons And vbOKCancel) = vbOKCancel Then
        bt3.visible = False
        bt2.visible = True
        bt2.Tag = vbOK
        bt2.caption = GetUser32ResourceString(RES_BT_OK)
        bt1.visible = True
        bt1.Tag = vbCancel
        bt1.caption = GetUser32ResourceString(RES_BT_Cancel)
        bt1.Cancel = True
    Else
        bt3.visible = False
        bt2.visible = False
        bt1.visible = True
        bt1.Tag = vbOK
        bt1.caption = GetUser32ResourceString(RES_BT_OK)
        bt1.Cancel = True
    End If
End Sub

'-----------------------------------------------------------------------------
' Redimension the dialog to display the message in the best possible way
'-----------------------------------------------------------------------------
Private Sub Redimension()
    Dim lngWidth As Long, lngHeight As Long
    Dim formWidth As Long, formHeight As Long
    Dim maxWidth As Long, maxHeight As Long
    Dim screenWidth As Long, screenHeight As Long
    Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long
    Dim boxHeight As Long, BoxWidth As Long
    Dim paddingWidth As Long, paddingHeight As Long
    Dim overflow As Boolean
       
    ' Compute maximal acceptable dialog box size in twips
    GetScreenResolution screenWidth, screenHeight
    screenWidth = ConvertPixelsToTwips(screenWidth, 0)
    screenHeight = ConvertPixelsToTwips(screenHeight, 0)
    maxWidth = screenWidth * 0.6
    maxHeight = screenHeight * 0.9
    
    ' Calculate the height and width of the area around the textbox
    formAllMarginsHeight = Me.WindowHeight - Section(acDetail).Height + txtMessage.Top
    formAllMarginsWidth = Me.Width - txtMessage.Width
    paddingWidth = txtMessage.LeftPadding + txtMessage.RightPadding
    paddingHeight = txtMessage.TopPadding + txtMessage.BottomPadding
        
    ' Make some adjustment to make the box a bit bigger for RichText
    ' The GetTextMetrics function uses the font informtation from the textbox.
    ' This gives us a better chance to have eveything fit in it.
    If m_IsRichText Then
        txtMessage.FontSize = txtMessage.FontSize + 1
    End If
    ' Compute the width of the textbox for the message we need to display
    API_GetTextMetrics.fTextWidth txtMessage, m_PlaintextPrompt, lngHeight, lngWidth
    BoxWidth = lngWidth + paddingWidth
    If BoxWidth > (maxWidth - formAllMarginsWidth) Then
        BoxWidth = (maxWidth - formAllMarginsWidth)
        lngWidth = BoxWidth - paddingWidth
    End If
    If BoxWidth > txtMessage.Width Then txtMessage.Width = BoxWidth
    
    ' Now calculate the height of the textbox for the message we need to display
    API_GetTextMetrics.fTextHeight txtMessage, m_PlaintextPrompt, lngHeight, lngWidth
    ' Adjust height for a better fit
    If m_IsRichText Then
        boxHeight = lngHeight * 1.15 + paddingHeight
    Else
        boxHeight = lngHeight + paddingHeight
    End If
    If boxHeight > (maxHeight - formAllMarginsHeight) Then
        overflow = True
        boxHeight = (maxHeight - formAllMarginsHeight)
    End If
    txtMessage.Height = boxHeight
    
    ' Make the textbox Font size normal again if we're dealing with RichText
    If m_IsRichText Then
        txtMessage.FontSize = txtMessage.FontSize - 1
    End If
    
    ' Assess proper width and height of the overall dialog box
    formWidth = txtMessage.Width + formAllMarginsWidth
    formHeight = txtMessage.Height + formAllMarginsHeight
    
    ' Adjust position of the th box to the middle if there is not much text.
    If formHeight < Me.WindowHeight Then
        formHeight = Me.WindowHeight
        If txtMessage.Height < Section(acDetail).Height Then
            txtMessage.Top = (Section(acDetail).Height - txtMessage.Height) / 2
        End If
    End If
    ' Adjust visible cues to ensure that we can still read the text when it overflows the maximum box size
    'If formWidth < Me.WindowWidth Then formWidth = Me.WindowWidth
    If overflow Then
        'reduce the height of the textbox just to make sure we see its border
        txtMessage.Height = txtMessage.Height - 5
        txtMessage.BackColor = Section("Detail").BackColor
        txtMessage.enabled = True
        txtMessage.BorderStyle = 1 'show border
        txtMessage.ScrollBars = 2 'show scrollbar
        txtMessage.SetFocus
    End If
        
    ' Redimension the dialog and display the message at the center of the screen
    DoCmd.MoveSize (screenWidth - formWidth) / 2, (screenHeight - formHeight) / 2, formWidth, formHeight
    txtMessage.Value = m_Prompt
    
    'Remove the selection on the textbox if necessary
    If txtMessage.enabled Then txtMessage.SelLength = 0
    
    ' Beep only if necessary
    'If ((m_Buttons And vbExclamation) = vbExclamation) Or ((m_Buttons And vbCritical) = vbCritical) Then Beep
End Sub

'-----------------------------------------------------------------------------
' Prevent the form from closing until the user has clicked one of the buttons
'-----------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
    Cancel = (m_Result < 0)
End Sub

'-----------------------------------------------------------------------------
' Right button clicked
'-----------------------------------------------------------------------------
Private Sub bt1_Click()
    m_Result = bt1.Tag
    visible = False
End Sub

'-----------------------------------------------------------------------------
' Middle button clicked
'-----------------------------------------------------------------------------
Private Sub bt2_Click()
    m_Result = bt2.Tag
    visible = False
End Sub

'-----------------------------------------------------------------------------
' Left button clicked
'-----------------------------------------------------------------------------
Private Sub bt3_Click()
    m_Result = bt3.Tag
    visible = False
End Sub

'-----------------------------------------------------------------------------
' Enable the buttons after the elapsed time set by ButtonDelay
'-----------------------------------------------------------------------------
Private Sub Form_Timer()
    TimerInterval = 0
    
    bt1.enabled = True
    bt2.enabled = True
    bt3.enabled = True
       
    Dim defaultbt As control
    Set defaultbt = bt1

    ' Detect Default button
    If (m_Buttons And vbYesNoCancel) = vbYesNoCancel Or (m_Buttons And vbAbortRetryIgnore) = vbAbortRetryIgnore Then ' 3 buttons
        If (m_Buttons And vbDefaultButton2) = vbDefaultButton2 Then
            Set defaultbt = bt2
        ElseIf (m_Buttons And vbDefaultButton3) = 0 Then
            Set defaultbt = bt3
        End If
    ElseIf (m_Buttons And vbYesNo) = vbYesNo Or (m_Buttons And vbOKCancel) = vbOKCancel Or (m_Buttons And vbRetryCancel) = vbRetryCancel Then ' 2 buttons
        If (m_Buttons And vbDefaultButton2) = 0 Then
            Set defaultbt = bt2
        End If
    End If
    
    defaultbt.Default = True
    defaultbt.SetFocus
    Set defaultbt = Nothing
End Sub

'-----------------------------------------------------------------------------
' Copy the message to the clipboard
'-----------------------------------------------------------------------------
Private Sub btCopy_Click()
    btDeadFocus.SetFocus
    ClipBoard_SetText m_PlaintextPrompt & ""
End Sub

'-----------------------------------------------------------------------------
' Copy the message to a text file.
' Here we just copy the message to the application folder
' In real life, we would do something more friendly such as create the file
' in a fodler on the user desktop or in My Documents
'-----------------------------------------------------------------------------
Private Sub btCopyToFile_Click()
    btDeadFocus.SetFocus
    Dim intFile As Integer
    Dim FName As String
    
    FName = MakeFriendlyFileName(m_SavedTextFileFolder, "Message - " & m_Title, "txt")
    
    intFile = FreeFile()
    Open FName For Output As #intFile
    Print #intFile, m_PlaintextPrompt & ""
    Close #intFile
    
    ' Now open the saved message
    ShellExecute 0, "open", Chr(34) & FName & Chr(34), 0, 0, SW_SHOWNORMAL
End Sub

'=============================================================================
' Helper functions
'=============================================================================

'-----------------------------------------------------------------------------
' Returns true if the file exists
'-----------------------------------------------------------------------------
Private Function FileExists(FileName As Variant) As Boolean
    FileExists = False
    If IsNull(FileName) Or IsEmpty(FileName) Then Exit Function
    On Error Resume Next
    FileExists = Len(Dir(FileName, vbNormal)) > 0
End Function

'-----------------------------------------------------------------------------
' Returns a file name based on the given friendly name and file extension
' Usage:
'   MakeFileName("Part List", "xls")
' will return
'   [application path]\Part List 2007-09-07 15h34.txt
' where [application path] is the path to the current database.
'-----------------------------------------------------------------------------
Private Function MakeFriendlyFileName(ByVal folderpath As String, ByVal friendlyname As String, ByVal Extension As String) As String
    Dim Path As String
    Dim FileName As String
    Dim fileexistcounter As Long
    
    ' Make sure we've got a sanitized filename and extension
    friendlyname = FilenameSanitize(Trim(friendlyname))
    If friendlyname = "" Then friendlyname = "(No filename given)"
    friendlyname = Mid(friendlyname, 1, 32)
    Extension = Trim(Extension)
    If Extension = "" Then Extension = "unknown"
    If Mid(Extension, 1) <> "." Then Extension = "." & Extension
    
    ' Construct the path without the extension
    If Right(folderpath, 1) <> "\" Then folderpath = folderpath & "\"
    Path = folderpath & friendlyname & " " & Format(Now, "yyyy-MM-dd Hh" & Chr(34) & "h" & Chr(34) & "Nn")
    
    ' If an other file already exists, then increment the file counter until we find one that is free
    Do
        If fileexistcounter > 0 Then
            FileName = Path & "(" & CStr(fileexistcounter) & ")" & Extension
        Else
            FileName = Path & Extension
        End If
        fileexistcounter = fileexistcounter + 1
    Loop While FileExists(FileName)
    
    ' return the final filen name
    MakeFriendlyFileName = FileName
    
End Function

'-----------------------------------------------------------------------------
' Sanitize the given filename to ensure it is valid.
' Return a version of the input string without any invalid characters.
' Note that only a filename without path information is expected (removes the \ as well).
'-----------------------------------------------------------------------------
Private Function FilenameSanitize(FileName As String) As String
    If FileName = "" Then Exit Function
    
    Dim i As Integer
    Dim C As String
    Dim charlen As Long
    charlen = Len(INVALID_FILENAME_CHARS)

    For i = 1 To charlen
        C = Mid(INVALID_FILENAME_CHARS, i, 1)
        FileName = Replace(FileName, C, "_")
    Next i
    FilenameSanitize = FileName
End Function

'-----------------------------------------------------------------------------
' Get the screen resolution
'-----------------------------------------------------------------------------
Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long)
    Dim R As RECT
    Dim hWnd As Long
    Dim retval As Long
    
    hWnd = GetDesktopWindow()
    retval = GetWindowRect(hWnd, R)
    Width = R.x2 - R.x1
    Height = R.y2 - R.y1
End Sub

'-----------------------------------------------------------------------------
' Pixel to Twips conversions
'-----------------------------------------------------------------------------
' cf http://support.microsoft.com/default.aspx?scid=kb;en-us;210590
' To call this function, pass the number of twips you want to convert,
' and another parameter indicating the horizontal or vertical measurement
' (0 for horizontal, non-zero for vertical). The following is a sample call:
'

Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long
   'Handle to device
   Dim lngDC As Long
   Dim lngPixelsPerInch As Long
   Const nTwipsPerInch = 1440
   lngDC = GetDC(0)
   
   If (lngDirection = 0) Then       'Horizontal
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
   Else                            'Vertical
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
   End If
   lngDC = ReleaseDC(0, lngDC)
   ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch
End Function

Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long
   'Handle to device
   Dim lngDC As Long
   Dim lngPixelsPerInch As Long
   Const nTwipsPerInch = 1440
   lngDC = GetDC(0)
   
   If (lngDirection = 0) Then       'Horizontal
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX)
   Else                            'Vertical
      lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY)
   End If
   lngDC = ReleaseDC(0, lngDC)
   ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch
End Function


             '----------------------------------------------------------------
             ' Procedure : ClipBoard_SetText
             ' Date      : 08/29/2011
             ' Purpose   :
             '----------------------------------------------------------------
             '
Function ClipBoard_SetText(strCopyString As String) As Boolean
  Dim hGlobalMemory As Long
  Dim lpGlobalMemory As Long
  Dim hClipMemory As Long

  ' Allocate moveable global memory.
  '-------------------------------------------
  hGlobalMemory = GlobalAlloc(GHND, Len(strCopyString) + 1)

  ' Lock the block to get a far pointer
  ' to this memory.
  lpGlobalMemory = GlobalLock(hGlobalMemory)

  ' Copy the string to this global memory.
  lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString)

  ' Unlock the memory and then copy to the clipboard
  If GlobalUnlock(hGlobalMemory) = 0 Then
    If OpenClipboard(0&) <> 0 Then
      Call EmptyClipboard
      hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
      ClipBoard_SetText = CBool(CloseClipboard)
    End If
  End If
End Function

'-----------------------------------------------------------------------------
' Get the given system resource string
'-----------------------------------------------------------------------------
' Inspired from http://www.thevbzone.com/l_res.htm
Private Function GetSystemResourceString(ResourcePath As String, resID As Long) As String
    
   Dim hLibrary As Long
   Dim strString As String
   Dim lngStringLen As Long
  
   ' Load the Resource DLL
   hLibrary = LoadLibrary(ResourcePath & Chr(0))
   If hLibrary = 0 Then
      MsgBox "Failed to load the specified library with error code " & Err.LastDllError
      Exit Function
   End If
  
   ' Get a string from the Resource DLL
   strString = String(256, Chr(0))
   lngStringLen = LoadString(hLibrary, resID, strString, Len(strString))
    
   ' Close the Resource DLL
   FreeLibrary hLibrary
  
  GetSystemResourceString = strString
End Function

Private Function GetUser32ResourceString(resID As Long) As String
    GetUser32ResourceString = GetSystemResourceString("user32.dll", resID)
End Function

Add a module called “Dialog”

and put this code into it:

'_______________________________________________________________________________________
' TYPE      : Module Dialog
' AUTHOR    : LoeblCom Services
' DATE      : 2018
'
' PURPOSE   :
'_______________________________________________________________________________________

Option Compare Database
Option Explicit

' Buttons in the box replacement become enabled after a 2 second delay by default
Private Const DEFAULT_BUTTON_DELAY = 2

Private m_DefaultTextFileFolder As Variant
Private m_DefaultButtonDelay As Variant
Private m_DefaultBeepAllowed As Variant

'-----------------------------------------------------------------------------
' The win32 Sleep function suspends the current thread for the given amount of milliseconds
' http://msdn.microsoft.com/en-us/library/ms686298.aspx
'-----------------------------------------------------------------------------
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'-----------------------------------------------------------------------------
' The time in seconds to wait until the buttons becomes active on the enhanced dialog
'-----------------------------------------------------------------------------

Public Property Get DefaultButtonDelay() As Long
If IsEmpty(m_DefaultButtonDelay) Then
    ' Initialize the default value
    m_DefaultButtonDelay = DEFAULT_BUTTON_DELAY
End If
DefaultButtonDelay = CLng(m_DefaultButtonDelay)
End Property

Public Property Let DefaultButtonDelay(delay As Long)
If delay < 0 Then delay = 0
m_DefaultButtonDelay = delay
End Property

'-----------------------------------------------------------------------------
' The default folder where the textfile will be saved
' The default value is the path to the folder where the current database is located
'-----------------------------------------------------------------------------
Public Property Get DefaultSavedTextFileFolder() As String
If IsEmpty(m_DefaultTextFileFolder) Then
    m_DefaultTextFileFolder = CurrentProject.Path & "\"
End If
DefaultSavedTextFileFolder = m_DefaultTextFileFolder
End Property

Public Property Let DefaultSavedTextFileFolder(folderpath As String)
m_DefaultTextFileFolder = folderpath
End Property

'-----------------------------------------------------------------------------
' Whether beeps are allowed or not when the message box opens
' The default is no.
'-----------------------------------------------------------------------------
Public Property Get DefaultBeepAllowed() As Boolean
If IsEmpty(m_DefaultBeepAllowed) Then
    m_DefaultBeepAllowed = False
End If
DefaultBeepAllowed = m_DefaultBeepAllowed
End Property

Public Property Let DefaultBeepAllowed(allow As Boolean)
m_DefaultBeepAllowed = allow
End Property


'-----------------------------------------------------------------------------
' Plain Text Replacement for the standard MsgBox
'-----------------------------------------------------------------------------
Public Function Box(ByVal Prompt As String, _
                    Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
                    Optional ByVal Title As String = "", _
                    Optional ByVal HelpFile As String = "", _
                    Optional ByVal HelpContextId As Long = 0, _
                    Optional ByVal ButtonDelay As Long = -1, _
                    Optional ByVal AllowBeep As Variant) _
                    As VbMsgBoxResult

' Create the MessageBox
Dim f          As New Form_MsgBoxDialog

f.Prompt = Prompt
f.Title = Title
f.Buttons = Buttons
f.HelpFile = HelpFile
f.HelpContextId = HelpContextId
f.ButtonDelay = IIf(ButtonDelay < 0, DefaultButtonDelay, ButtonDelay)
f.AllowBeep = IIf(IsMissing(AllowBeep), DefaultBeepAllowed, AllowBeep)
f.SavedTextFileFolder = DefaultSavedTextFileFolder
f.IsRichText = False

' Make it visible and wait for the user until we get the result
Box = f.ShowModal()

' cleanup
Set f = Nothing

End Function

'-----------------------------------------------------------------------------
' Rich-Text Replacement for the standard MsgBox
'-----------------------------------------------------------------------------
Public Function RichBox(ByVal Prompt As String, _
                        Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
                        Optional ByVal Title As String = "", _
                        Optional ByVal HelpFile As String = "", _
                        Optional ByVal HelpContextId As Long = 0, _
                        Optional ByVal ButtonDelay As Long = -1, _
                        Optional ByVal AllowBeep As Boolean = True) _
                        As VbMsgBoxResult

' Create the MessageBox
Dim f          As New Form_MsgBoxDialog
f.Prompt = Prompt
f.Title = Title
f.Buttons = Buttons
f.HelpFile = HelpFile
f.HelpContextId = HelpContextId
f.ButtonDelay = IIf(ButtonDelay < 0, m_DefaultButtonDelay, ButtonDelay)
f.AllowBeep = IIf(IsMissing(AllowBeep), DefaultBeepAllowed, AllowBeep)
f.SavedTextFileFolder = DefaultSavedTextFileFolder
f.IsRichText = True

' Make it visible and wait forthe user until we get the result
RichBox = f.ShowModal()

' cleanup
Set f = Nothing

End Function

Finally Add A Module called “API_GetTextMetrics”

and add this code:

'_______________________________________________________________________________________
' TYPE      : Module API_GetTextMetrics
' AUTHOR    : LoeblCom Services
' DATE      : 2018
'
' PURPOSE   : Control the size of a message box by calculating Width and Height based on text.
'_______________________________________________________________________________________

Option Compare Database
Option Explicit


Private Type RECT
    Left       As Long
    Top        As Long
    Right      As Long
    Bottom     As Long
End Type

Private Const LF_FACESIZE = 32

Private Type LOGFONT
    lfHeight   As Long
    lfWidth    As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight   As Long
    lfItalic   As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet  As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality  As Byte
    lfPitchAndFamily As Byte
    lfFaceName As String * LF_FACESIZE
End Type

Private Type TEXTMETRIC
    tmHeight   As Long
    tmAscent   As Long
    tmDescent  As Long
    tmInternalLeading As Long
    tmExternalLeading As Long
    tmAveCharWidth As Long
    tmMaxCharWidth As Long
    tmWeight   As Long
    tmOverhang As Long
    tmDigitizedAspectX As Long
    tmDigitizedAspectY As Long
    tmFirstChar As Byte
    tmLastChar As Byte
    tmDefaultChar As Byte
    tmBreakChar As Byte
    tmItalic   As Byte
    tmUnderlined As Byte
    tmStruckOut As Byte
    tmPitchAndFamily As Byte
    tmCharSet  As Byte
End Type

Private Declare PtrSafe Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long

Private Declare PtrSafe Function apiCreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Private Declare PtrSafe Function apiSelectObject Lib "gdi32" Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare PtrSafe Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long

Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Private Declare PtrSafe Function apiMulDiv Lib "kernel32" Alias "MulDiv" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Declare PtrSafe Function apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long

Private Declare PtrSafe Function apiReleaseDC Lib "user32" Alias "ReleaseDC" (ByVal hWnd As Long, ByVal hdc As Long) As Long

Private Declare PtrSafe Function apiDrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Declare PtrSafe Function CreateDCbyNum Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As Long, ByVal lpInitData As Long) As Long  'DEVMODE) As Long

Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long

Declare PtrSafe Function GetProfileString Lib "kernel32" _
        Alias "GetProfileStringA" _
        (ByVal lpAppName As String, _
         ByVal lpKeyName As String, _
         ByVal lpDefault As String, _
         ByVal lpReturnedString As String, _
         ByVal nSize As Long) As Long


' CONSTANTS
Private Const TWIPSPERINCH = 1440
' Used to ask System for the Logical pixels/inch in X & Y axis
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88

' DrawText() Format Flags
Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_EDITCONTROL = &H2000&
Private Const DT_NOCLIP = &H100



' Font stuff
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_PRECIS = 4
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_OUTLINE_PRECIS = 8

Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_MASK = &HF
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_TT_ALWAYS = 32
Private Const CLIP_EMBEDDED = 128

Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2

Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2

Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255
'

Public Function fTextHeight(ctl As control, _
                            Optional ByVal sText As String = "", _
                            Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
                            Optional TotalLines As Long = 0, _
                            Optional TwipsPerPixel As Long = 0) As Long

On Error Resume Next

' Call our function to calculate TextHeight
' If blWH=TRUE then we are TextHeight
fTextHeight = fTextWidthOrHeight(ctl, True, _
                                 sText, HeightTwips, WidthTwips, TotalLines, TwipsPerPixel)

End Function


Public Function fTextWidth(ctl As control, _
                           Optional ByVal sText As String = "", _
                           Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
                           Optional TotalLines As Long = 0, _
                           Optional TwipsPerPixel As Long = 0) As Long

On Error Resume Next

' If blWH=FALSE then we are TextWidth
' Call our function to calculate TextWidth
fTextWidth = fTextWidthOrHeight(ctl, False, _
                                sText, HeightTwips, WidthTwips, TotalLines, TwipsPerPixel)
End Function

Public Function fTextWidthOrHeight(ctl As control, ByVal blWH As Boolean, _
                                   Optional ByVal sText As String = "", _
                                   Optional HeightTwips As Long = 0, Optional WidthTwips As Long = 0, _
                                   Optional TotalLines As Long = 0, _
                                   Optional TwipsPerPixel As Long = 0) As Long


' Structure for DrawText calc
Dim sRect      As RECT

' Reports Device Context
Dim hdc        As Long

' Holds the current screen resolution
Dim lngDPI     As Long

Dim newfont    As Long
' Handle to our Font Object we created.
' We must destroy it before exiting main function

Dim oldfont    As Long
' Device COntext's Font we must Select back into the DC
' before we exit this function.

' Temporary holder for returns from API calls
Dim lngRet     As Long

' Logfont struct
Dim myfont     As LOGFONT

' TextMetric struct
Dim tm         As TEXTMETRIC

' LineSpacing Amount
Dim lngLineSpacing As Long

' Ttemp var
Dim numLines   As Long

' Temp string var for current printer name
Dim strName    As String

' Temp vars
Dim sngTemp1   As Single
Dim sngTemp2   As Single

On Error GoTo Err_Handler

' Get handle to screen Device Context
hdc = apiGetDC(0&)

' Were we passed a valid string
If Len(sText & vbNullString) = 0 Then
    ' Did we get a valid control passed to us?
    'select case typeof ctl is
    Select Case ctl.ControlType
        Case acTextBox
            sText = Nz(ctl.Value, vbNullString)
        Case acLabel, acCommandButton
            sText = Nz(ctl.caption, vbNullString)
        Case acListBox
            sText = Nz(ctl.ItemData(0), vbNullString)
        Case Else
            ' Fail - not a control we can work with
            fTextWidthOrHeight = 0
            Exit Function
    End Select
End If


' Get current device resolution
' blWH=TRUE then we are TextHeight
If blWH Then
    lngDPI = apiGetDeviceCaps(hdc, LOGPIXELSY)
Else
    lngDPI = apiGetDeviceCaps(hdc, LOGPIXELSX)
End If

' Calculate TwipsPerPixel
TwipsPerPixel = TWIPSPERINCH / lngDPI

' We use a negative value to signify
' to the CreateFont function that we want a Glyph
' outline of this size not a bounding box.
' Copy font stuff from Text Control's property sheet
With ctl
    myfont.lfClipPrecision = CLIP_LH_ANGLES
    myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
    myfont.lfEscapement = 0
    myfont.lfFaceName = .FontName & Chr$(0)
    myfont.lfWeight = .FontWeight
    myfont.lfItalic = .FontItalic
    myfont.lfUnderline = .FontUnderline
    'Must be a negative figure for height or system will return
    'closest match on character cell not glyph
    myfont.lfHeight = (.FontSize / 72) * -lngDPI
    ' Create our temp font
    newfont = apiCreateFontIndirect(myfont)
End With

If newfont = 0 Then
    Err.Raise vbObjectError + 256, "fTextWidthOrHeight", "Cannot Create Font"
End If

' Select the new font into our DC.
oldfont = apiSelectObject(hdc, newfont)
' Use DrawText to Calculate height of Rectangle required to hold
' the current contents of the Control passed to this function.
With sRect
    .Left = 0
    .Top = 0
    .Bottom = 0
    ' blWH=TRUE then we are TextHeight
    If blWH Then
        If WidthTwips > 0 Then
            .Right = WidthTwips / (TWIPSPERINCH / lngDPI)
        Else
            .Right = ((ctl.Width - ctl.LeftPadding - ctl.RightPadding) / (TWIPSPERINCH / lngDPI)) - 10
        End If
    Else
        If WidthTwips > 0 Then
            .Right = WidthTwips / (TWIPSPERINCH / lngDPI)
        Else
            ' Single line TextWidth
            .Right = 32000
        End If
    End If

    ' Calculate our bounding box based on the controls current width
    lngRet = apiDrawText(hdc, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or DT_NOCLIP)

    ' Get TextMetrics. This is required to determine
    ' Text height and the amount of extra spacing between lines.
    lngRet = GetTextMetrics(hdc, tm)

    ' Cleanup
    lngRet = apiSelectObject(hdc, oldfont)
    ' Delete the Font we created
    apiDeleteObject (newfont)

    ' Release the handle to the Screen's DC
    lngRet = apiReleaseDC(0&, hdc)

    ' Calculate how many lines we are displaying
    ' return to calling function. The GDI incorrectly
    ' calculates the bounding rectangle because
    ' of rounding errors converting to Integers.
    TotalLines = .Bottom / (tm.tmHeight + tm.tmExternalLeading)
    numLines = TotalLines

    ' Convert RECT values to TWIPS
    .Bottom = (.Bottom) * (TWIPSPERINCH / lngDPI)     'sngTemp2 ' + 20

    ' Return values in optional vars
    ' Convert RECT Pixel values to TWIPS
    HeightTwips = .Bottom     '* (TWIPSPERINCH / lngDPI)
    WidthTwips = .Right * (TWIPSPERINCH / lngDPI)     '(apiGetDeviceCaps(hDC, LOGPIXELSX)))

    ' blWH=TRUE then we are TextHeight
    If blWH Then
        fTextWidthOrHeight = HeightTwips
    Else
        fTextWidthOrHeight = WidthTwips
    End If
End With

' Exit normally
Exit_OK:
Exit Function

Err_Handler:
Err.Raise Err.Source, Err.Number, Err.Description
Resume Exit_OK
End Function

Now you should be good to go.

Let me know if you have any questions.

By the way, if you got or are getting value from the VBA information, please click the "Donate" button to give me a small token of your appreciation, thanks!