Attribute VB_Name = "Unicode"
Option Explicit

Private Const CF_UNICODETEXT As Long = 13
Private Const WM_COPY As Long = &H301

Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Function RichTextUnicode(RichTextBox As RichTextBox) As String

Dim Try As Long
Dim hMem As Long
Dim memSize As Long
Dim lPtr As Long
Dim bData() As Byte

'copy Unicode text from RichTextBox to the Clipboard
Clipboard.Clear
RichTextBox.SetFocus
RichTextBox.SelStart = 0
RichTextBox.SelLength = Len(RichTextBox.Text) * 2
SendMessage RichTextBox.hWnd, WM_COPY, 0, 0

'get Unicode text in a global, movable memory block
For Try = 1 To 3
  OpenClipboard RichTextBox.hWnd
  hMem = GetClipboardData(CF_UNICODETEXT)
  If hMem <> 0 Then
    Exit For
  End If
  CloseClipboard
  DoEvents
Next Try
If hMem = 0 Then
  CloseClipboard
  Exit Function
End If

memSize = GlobalSize(hMem)
If memSize = 0 Then
  CloseClipboard
  Exit Function
End If

'get a non-movable global pointer to the Unicode text
lPtr = GlobalLock(hMem)
If lPtr = 0 Then
  CloseClipboard
  Exit Function
End If

'copy Unicode text to the String "s"
ReDim bData(0 To memSize - 1) As Byte
CopyMemory bData(0), ByVal lPtr, memSize
GlobalUnlock hMem
RichTextUnicode = bData

CloseClipboard

End Function

Public Function UnicodeToUTF8(ByVal Unicode As String) As String

Dim V As Long
Dim Scan As Long

If Right(Unicode, 1) = Chr(0) Then
  Unicode = Left(Unicode, Len(Unicode) - 1)
End If

For Scan = 1 To Len(Unicode)
  V = AscW(Mid(Unicode, Scan, 1))
  If V < 0 Then
    V = V + 65536
  End If
' Debug.Print Scan, V, Hex(V), V \ 256, V And 255
  If V <= &H7F Then
    UnicodeToUTF8 = UnicodeToUTF8 & Chr(V)
  ElseIf V <= &H7FF Then
    UnicodeToUTF8 = UnicodeToUTF8 & Chr(&HC0 + (V \ 64)) & Chr(&H80 + (V And 63))
  Else
    UnicodeToUTF8 = UnicodeToUTF8 & Chr(&HE0 + (V \ 4096)) & Chr(&H80 + ((V \ 64) And 63)) & Chr(&H80 + (V And 63))
  End If
Next Scan
'Debug.Print

End Function