VBA: Show a message box of selected VBA code but with hardcoded Unicode characters rendered

show_text_for_codepoints.bas

#If VBA7 Then
    Private Declare PtrSafe Function MessageBoxW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal uType As Long) As Long
#Else
    Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal uType As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#Else
    Private Declare Function MessageBoxW Lib "user32" () As Long
#End If

Public Function MsgBoxW(Prompt As String, Optional Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = "Microsoft Excel") As VbMsgBoxResult
    Prompt = Prompt & vbNullChar 'Add null terminators
    Title = Title & vbNullChar
    MsgBoxW = MessageBoxW(GetActiveWindow(), StrPtr(Prompt), StrPtr(Title), Buttons)
End Function

Public Sub ShowCharForCodePoint()
    Dim selectedCode As String
    selectedCode = GetSelectedVBACode()
    MsgBoxW ChrW$(CLng(selectedCode))
End Sub
' &H3001

Public Sub RenderUnicodeFromVBACode()
    Dim selectedCode As String
    selectedCode = GetSelectedVBACode()
    
    'variables used in both loops to catch hex codepoints and decimal codepoints
    Dim i As Long
    Dim codepoint As Long
    
    'replace ChrW calls with hardcoded hex codepoints
    Dim codepointInChrWFinder As New RegExp
    codepointInChrWFinder.pattern = "ChrW\$?\((&H[0-9A-Fa-f]+)\)"
    codepointInChrWFinder.Global = True
    Dim hexInChrWs As MatchCollection
    Set hexInChrWs = codepointInChrWFinder.Execute(selectedCode)
    
    Dim hexMatch As Match
    For i = hexInChrWs.Count - 1 To 0 Step -1
        Set hexMatch = hexInChrWs.Item(i)
        codepoint = CLng(hexMatch.SubMatches.Item(0))
        selectedCode = Left$(selectedCode, hexMatch.FirstIndex) & """" & ChrW$(codepoint) & """" & Mid$(selectedCode, hexMatch.FirstIndex + 1 + hexMatch.Length)
    Next i
    
    'replace ChrW calls with hardcoded decimal codepoints
    codepointInChrWFinder.pattern = "ChrW\$?\((\d+)\)"
    Dim decInChrWs As MatchCollection
    Set decInChrWs = codepointInChrWFinder.Execute(selectedCode)
    
    Dim decMatch As Match
    For i = decInChrWs.Count - 1 To 0 Step -1
        Set decMatch = decInChrWs.Item(i)
        codepoint = CLng(decMatch.SubMatches.Item(0))
        selectedCode = Left$(selectedCode, decMatch.FirstIndex) & """" & ChrW$(codepoint) & """" & Mid$(selectedCode, decMatch.FirstIndex + 1 + decMatch.Length)
    Next i
    
    selectedCode = Replace(selectedCode, """ & """, "")
    MsgBoxW selectedCode
End Sub

'Test = ChrW$(&H3053) & ChrW$(&H3093) & ChrW$(&H306B) & ChrW$(&H3061) & ChrW$(&H306F) & ChrW$(&HFF01)
'ChrW$(12376) & ChrW$(12419) & ChrW$(12397) & ChrW$(65281)

Public Function GetSelectedVBACode() As String
    Dim pane As CodePane
    Dim codeMod As CodeModule
    Set pane = Application.VBE.ActiveCodePane
    Set codeMod = pane.CodeModule
    
    Dim startLine As Long, startCol As Long, endLine As Long, endCol As Long
    pane.GetSelection startLine, startCol, endLine, endCol
    
    Dim selectedCode As String
    selectedCode = codeMod.Lines(startLine, endLine - startLine + 1)
    If startLine = endLine Then
        selectedCode = Mid$(selectedCode, startCol, endCol - startCol)
    Else
        Dim lastLine As String
        Dim rightTrimCount As Long
        lastLine = codeMod.Lines(endLine, 1)
        rightTrimCount = Len(lastLine) - endCol
        selectedCode = Mid$(selectedCode, startCol, Len(selectedCode) - startCol - rightTrimCount)
    End If
    GetSelectedVBACode = selectedCode
End Function

References Microsoft VBScript Regular Expressions 5.5 and Microsoft Visual Basic for Applications Extensibility 5.3.