1 Attachment(s)
[VB6/Win8+] Using DirectX to show emojis with color
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:
https://www.vbforums.com/attachment....hmentid=187688
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.
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)
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
Quote:
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
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 :)
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
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:
https://www.vbforums.com/attachment....hmentid=187688
