Results 1 to 7 of 7

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

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    6,346

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


    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:

    Attached Files Attached Files
    Last edited by fafalone; May 22nd, 2023 at 12:04 AM. Reason: Added additional notes and reqs details

  2. #2
    Fanatic Member
    Join Date
    Jun 2016
    Location
    España
    Posts
    549

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

    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.

  3. #3

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    6,346

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

    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)
    Last edited by fafalone; Apr 29th, 2023 at 08:42 AM.

  4. #4
    Fanatic Member
    Join Date
    Jun 2016
    Location
    España
    Posts
    549

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

    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

  5. #5

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    6,346

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

    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

  6. #6
    Fanatic Member
    Join Date
    Jun 2016
    Location
    España
    Posts
    549

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

    It is somewhat fast and not optimized.
    ClsEmoji.cls
    Code:
    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
    Code:
    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

  7. #7

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    6,346

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

    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:

    Last edited by fafalone; May 22nd, 2023 at 12:04 AM.

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width