[VB6/Win8+] Using DirectX to show emojis with color

[fafalone]

ColorEmojiDemo

With phones and web browsers, people are getting used to seeing emojis with color everywhere. But disappointingly, the basic Windows GDI functions do not support these, so in VB6 (and Explorer and anywhere using the default old GDI stuff), even when you support Unicode to display emojis, you only see them in black and white. So how do you get them to show in color? One way is using DirectX-- Direct2D and DirectWrite. This is a simple demo that just renders a test string directly onto the form.

Requirements
Windows 8.1 or newer - This *may* work if you've got a newer DirectX version on Win7 and have installed update KB2729094, but it's officially documented as 8.1+ only for the critical D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT flag. I've only tested it on my system, which is Windows 10 1809.
oleexp v6.2 or newer - Only required in the IDE; does not need to be distributed with the compiled .exe. This uses DirectX COM interfaces defined in the oleexp.tlb type library. The trick graciously allowed integrating his d2dvb and dwvb typelibs with oleexp, and I expanded them to include all related interfaces and other DirectX modules. You could likely substitute those with little to no change.

Notes
Not all fonts support color emojis, and Windows/DirectX does not support all color font formats. The demo uses Segoe UI, which is a built-in Windows font on newer versions that does. You'll have to check both whether support is there and what format it is for other fonts (any of the preinstalled Windows fonts would be in the right format *if* they are colorized, but 3rd party may be in other formats as Android and Apple platforms support different ones).

This code is 64-bit ready; you'd just need to add PtrSafe to the APIs (or remove them) and substitute tbShellLib for oleexp. I was originally going to publish it in twinBASIC, but there's currently a bug preventing it from working. Such is the nature of beta software. Look for it soon

Heavily based on a wonderful demo by Code Doggo on StackOverflow
For simplicity I've rendered it directly onto a VB form rather than create a dedicated window. In the future, I might make this into an edit control.

---

There's now also a twinBASIC version of this project which supports 64bit compilation. Note: Currently only works when compiled.

twinBASIC DirectX Color Emoji Demo

What's fun about twinBASIC is you don't need the hacks like ChrW2 to get emojis into a String. You can just use normal string assingments:

[yokesee]

Thank you very much it looks very good.

It could be moved to a class to be easier to use.

The oleexp version in project is v6.3 and the latest one is v6.2 but it works perfectly.

Greetings, thanks for all the contributions.

[fafalone]

Glad people find them useful!

Indeed there's lots of options for making it more practical, hopefully this proof-of-concept inspires something

I am thinking about making a textbox control supporting this... but I don't know how useful a single line one would be, and multiline would be very complex and time consuming (because it would be entirely from scratch; would even have to manually draw the cursor blinking). Certainly possible, but there's so many cool things to work on

(Re: oleexp version, I've started work on the next version, it's just not done yet so only on my system, but it doesn't touch anything involved in this project, besides adding the missing D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT enum value, so yes shouldn't be causing any problems since the project defines that locally)

[yokesee]

I have moved everything to a class and I have used The Trick's Class for subclassing and it works perfect.
https://www.vbforums.com/showthread....ws-and-classes

I am thinking about making a textbox control supporting this... but I don't know how useful a single line one would be, and multiline would be very complex and time consuming (because it would be entirely from scratch; would even have to manually draw the cursor blinking). Certainly possible, but there's so many cool things to work on

I think it's a lot of work.
Ask Krol, implement some easy way in your Textbox control.

All the best

[fafalone]

Krool's TextBox is based on the standard Windows edit control too, so it's unlikely to be more practical than rewriting from scratch (you could use the theme APIs to draw edges and use existing scrollbar APIs so it's not *entirely* from scratch, but you would have to manage text rendering entirely manually).

If you've got a class to render to an arbitrary hwnd, by all means post it, sounds interesting

[yokesee]

It is somewhat fast and not optimized.
ClsEmoji.cls

Option Explicit
'ColorEmojiDemo v0.1
'by Jon Johnson (fafalone)
'Edited Yokesee
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As Any, ByVal bErase As BOOL) As BOOL
Private Declare Function ValidateRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As Any) As BOOL

Private WindowHandle As LongPtr
Private DWriteFactory As IDWriteFactory
Private Direct2dFactory As ID2D1Factory
Private RenderTarget As ID2D1HwndRenderTarget
Private TextBlackBrush As ID2D1SolidColorBrush



Private DISPLAY_TEXT As String

Private Const sc_redShift = 16
Private Const sc_greenShift = 8
Private Const sc_blueShift = 0

Private Const sc_redMask = &HFF0000 '&Hff << sc_redShift
Private Const sc_greenMask = &HF00 '&Hff << sc_greenShift
Private Const sc_blueMask = &HFF '&Hff << sc_blueShift

'This is a newer flag so was missing from the current public version of oleexp
Private Const D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4

Private WithEvents m_cFormHook  As CTrickSubclass
Public Sub Hook(hWnd As Long)
    Set m_cFormHook = New CTrickSubclass
    WindowHandle = hWnd

    If CreateDeviceIndependentResources = S_OK Then
        m_cFormHook.Hook hWnd
    End If
End Sub

Public Property Let Text(Text As String)
    DISPLAY_TEXT = Text
    OnRender
End Property

Private Sub Class_Terminate()
    Set m_cFormHook = Nothing
End Sub

Private Sub m_cFormHook_WndProc( _
            ByVal hWnd As OLE_HANDLE, _
            ByVal lMsg As Long, _
            ByVal wParam As Long, _
            ByVal lParam As Long, _
            ByRef lRet As Long, _
            ByRef bDefCall As Boolean)
    Select Case lMsg
        Case WM_SIZE
            Dim cx As Long: cx = LoWord(CLng(lParam))
            Dim cy As Long: cy = HiWord(CLng(lParam))
            
            If (RenderTarget Is Nothing) = False Then
                Dim tSz As D2D1_SIZE_U
                tSz.Width = cx
                tSz.Height = cy
                RenderTarget.Resize tSz

            End If
            DebugAppend "size::" & cx & "," & cy
            bDefCall = True
        Case WM_DISPLAYCHANGE
            InvalidateRect hWnd, ByVal 0, 0
            
            bDefCall = True
        Case WM_PAINT
            OnRender
            ValidateRect hWnd, ByVal 0
            
            bDefCall = True
        Case WM_MOUSEWHEEL
            bDefCall = True
        Case Else
            bDefCall = True
    End Select
    
End Sub
Private Function IID_IDWriteFactory() As UUID
    '{B859EE5A-D838-4B5B-A2E8-1ADC7D93DB48}
    Static iid As UUID
     If (iid.Data1 = 0&) Then Call DEFINE_UUID(iid, &HB859EE5A, CInt(&HD838), CInt(&H4B5B), &HA2, &HE8, &H1A, &HDC, &H7D, &H93, &HDB, &H48)
    IID_IDWriteFactory = iid
End Function
Private Function IID_ID2D1Factory() As UUID
    '{06152247-6F50-465A-9245-118BFD3B6007}
    Static iid As UUID
     If (iid.Data1 = 0&) Then Call DEFINE_UUID(iid, &H6152247, CInt(&H6F50), CInt(&H465A), &H92, &H45, &H11, &H8B, &HFD, &H3B, &H60, &H7)
    IID_ID2D1Factory = iid
End Function
Private Function CreateDeviceIndependentResources() As Long
    On Error Resume Next 'Manual error handling
    Dim hr As Long '= S_OK
    Set Direct2dFactory = D2D1CreateFactory(D2D1_FACTORY_TYPE_SINGLE_THREADED, IID_ID2D1Factory, ByVal 0)
    If (Direct2dFactory Is Nothing) Then hr = S_FALSE
    If SUCCEEDED(hr) Then
        Set DWriteFactory = DWriteCreateFactory(DWRITE_FACTORY_TYPE_SHARED, IID_IDWriteFactory)
        If (DWriteFactory Is Nothing) Then hr = S_FALSE
        DebugAppend "D2D1CreateFactory succeeded; DWriteCreateFactory hr=0x" & Hex$(hr)
    Else
        DebugAppend "D2D1CreateFactory failed, hr=0x" & Hex$(hr)
    End If
    CreateDeviceIndependentResources = hr
End Function

Private Function CreateDeviceResources() As Long
    On Error GoTo e0
    Dim hr As Long '= S_OK
    Dim rc As RECT
    If RenderTarget Is Nothing Then
        GetClientRect WindowHandle, rc
        Dim size As D2D1_SIZE_U
        Dim rtProps As D2D1_RENDER_TARGET_PROPERTIES
        Dim hwndProps As D2D1_HWND_RENDER_TARGET_PROPERTIES
        size.Width = rc.Right - rc.Left
        size.Height = rc.Bottom - rc.Top
        hwndProps.hWnd = WindowHandle
        hwndProps.pixelSize = size
        Set RenderTarget = Direct2dFactory.CreateHwndRenderTarget(rtProps, hwndProps)
        If SUCCEEDED(hr) Then
            Dim clrBlack As D2D1_COLOR_F
            clrBlack.a = 1#
            Set TextBlackBrush = RenderTarget.CreateSolidColorBrush(clrBlack, ByVal 0)
            DebugAppend "D2D1CreateFactory::CreateHwndRenderTarget succeeded; RenderTarget.CreateSolidColorBrush hr=0x" & Hex$(hr)
        Else
            DebugAppend "D2D1CreateFactory::CreateHwndRenderTarget failed, hr=0x" & Hex$(hr)
        End If
        CreateDeviceResources = hr
    End If
Exit Function
e0:
    hr = Err.Number
    Resume Next
End Function

Public Function OnRender() As Long
    On Error GoTo e0
    Dim hr As Long '= S_OK
    Dim RenderCanvasArea As D2D1_SIZE_F
    Dim TextFormat As IDWriteTextFormat
    Dim TextCanvasArea As D2D1_RECT_F
    Dim clrWhite As D2D1_COLOR_F
    
    hr = CreateDeviceResources()
    
    If SUCCEEDED(hr) Then
        RenderTarget.BeginDraw
        RenderCanvasArea = RenderTarget.GetSize()
 
        clrWhite.r = 1#: clrWhite.g = 1#: clrWhite.b = 1#: clrWhite.a = 1#
        RenderTarget.Clear clrWhite ' D2D1.ColorF(White)
 
        If SUCCEEDED(hr) Then
            Set TextFormat = DWriteFactory.CreateTextFormat(StrPtr("Segoe UI"), _
                                                            Nothing, _
                                                            DWRITE_FONT_WEIGHT_REGULAR, _
                                                            DWRITE_FONT_STYLE_NORMAL, _
                                                            DWRITE_FONT_STRETCH_NORMAL, _
                                                            25, _
                                                            StrPtr("en-us"))
 
            If (SUCCEEDED(hr)) And ((TextFormat Is Nothing) = False) Then
                TextFormat.SetTextAlignment (DWRITE_TEXT_ALIGNMENT_LEADING)
                TextFormat.SetParagraphAlignment (DWRITE_PARAGRAPH_ALIGNMENT_NEAR)
                TextFormat.SetReadingDirection (DWRITE_READING_DIRECTION_LEFT_TO_RIGHT)
                TextFormat.SetWordWrapping (DWRITE_WORD_WRAPPING_WRAP)
                
                TextCanvasArea.Right = RenderCanvasArea.Width
                TextCanvasArea.Bottom = RenderCanvasArea.Height
                
                RenderTarget.DrawText DISPLAY_TEXT, Len(DISPLAY_TEXT), ByVal ObjPtr(TextFormat), TextCanvasArea, TextBlackBrush, D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT, 0
                
            End If
        End If
        
        RenderTarget.EndDraw ByVal 0, ByVal 0
 
    End If
    
    If hr = D2DERR_RECREATE_TARGET Then
        Set RenderTarget = Nothing
        Set TextBlackBrush = Nothing
        hr = S_OK
    End If
    
    OnRender = hr

Exit Function
e0:
    hr = Err.Number
    Resume Next
End Function

Form1.frm

Option Explicit
Private Emoji As New ClsEmoji
Private Emoji2 As New ClsEmoji

Private Sub Form_Load()
    Emoji.Text = ChrW2(&H1F601) & " Test " & ChrW2(&H1F601) & vbCrLf & _
                        ChrW2(&H1F608) & " Holiii! Color emojis! " & ChrW2(&H1F60D)
    Emoji.Hook Me.hWnd
    
    Emoji2.Text = ChrW2(&H1F618) & ChrW2(&H1F601) & vbCrLf & _
                        ChrW2(&H1F508) & ChrW2(&H1F509) & ChrW2(&H1F50A) & vbCrLf & _
                        ChrW2(&H1F4C5) & ChrW2(&H1F4C6) & ChrW2(&H1F5D2) & vbCrLf & _
                        ChrW2(&H1F435) & ChrW2(&H1F1EA) & ChrW2(&H1F1F8) & vbCrLf & _
                        ChrW2(&H1F349) & ChrW2(&H1F63B) & ChrW2(&H1F383) & vbCrLf & _
                        ChrW2(&H26BD) & ChrW2(&H1F3AE) & ChrW2(&H1F383)
                        
    Emoji2.Hook Picture1.hWnd
End Sub

[fafalone]

There's now a twinBASIC version of this project which supports 64bit compilation. Note: Currently only works when compiled.

twinBASIC DirectX Color Emoji Demo

What's fun about twinBASIC is you don't need the hacks like ChrW2 to get emojis into a String. You can just use normal string assingments: