Working for M2000 Interpreter I found this https://support.microsoft.com/en-us/kb/274326
For copy text to Html, but without using utf-8 (but works for english because utf-8 has one byte for English language). So I do the job to make this to send text in utf-8 format, so it can be used for export colored text, or in other format, and we can paste this to an office application like Word or in a Blog (in blogspot, as I do for my Intertpeter, M2000)
Put this in a Module and call TestThis from Immediate Mode.
I also include two helpers, the SpellUnicode which get a string and give a string of parameters. These parameters are for ListenUnicode which convert back to unicode string. Is the only way to pass unicode strings in a Module file (without using external file or a resource like .res file).
Enjoy it
For copy text to Html, but without using utf-8 (but works for english because utf-8 has one byte for English language). So I do the job to make this to send text in utf-8 format, so it can be used for export colored text, or in other format, and we can paste this to an office application like Word or in a Blog (in blogspot, as I do for my Intertpeter, M2000)
Put this in a Module and call TestThis from Immediate Mode.
I also include two helpers, the SpellUnicode which get a string and give a string of parameters. These parameters are for ListenUnicode which convert back to unicode string. Is the only way to pass unicode strings in a Module file (without using external file or a resource like .res file).
Enjoy it
Code:
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
"RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private m_cfHTMLClipFormat As Long
Private Const Utf8CodePage As Long = 65001
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar& Lib "kernel32" (ByVal codepage&, ByVal dwFlags&, MultiBytes As Any, ByVal cBytes&, ByVal pWideChars&, ByVal cWideChars&)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock 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 CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' here is the sub for send text to clipboard as unicode and as Html Format -utf8
Public Sub TestThis()
Copy2Clipboard ListenUnicode(915, 953, 974, 961, 947, 959, 962, 32, 922, 945, 961, 961, 940, 962) + vbCrLf + "Greetings from George Karras from West Greece"
End Sub
Public Sub Copy2Clipboard(ByVal unicodetext As String)
Dim ph As String
Clipboard.Clear ' always
DoEvents
Sleep 10
ph = PrepareHtml(unicodetext) ' here you have to prepare for html
SimpleHtmlData ph
SetTextData 13, unicodetext
End Sub
Function ReplaceStr(sStr As String, dStr As String, fromStr As String) As String
'' Sory but i like this one, with source first
ReplaceStr = Replace$(fromStr, sStr, dStr)
End Function
Private Function PrepareHtml(neodata As String) As String
Dim A$
' WE DO SOME WORK TO PRESERVE FORMAT
' MAYBE IS NOT COMPLETE BUT IT IS A TRY
A$ = ReplaceStr("</", Chr$(1) + Chr$(2), neodata)
A$ = ReplaceStr("<", Chr$(3), A$)
A$ = ReplaceStr(">", Chr$(4), A$)
A$ = ReplaceStr(" ", Chr$(7) + Chr$(7), A$)
A$ = ReplaceStr(Chr$(7) + " ", Chr$(7) + Chr$(7), A$)
'' here you can process line by line and or embed tags
A$ = "<FONT COLOR=blue>" + A$ + "</FONT>"
A$ = ReplaceStr(Chr$(1) + Chr$(2), "<⁄", A$)
A$ = ReplaceStr(Chr$(3), "<", A$)
A$ = ReplaceStr(Chr$(4), ">", A$)
' SO ALL SPACES ARE NOW NBSP IF ARE IN A SEQUENCE OF TWO OR MORE
A$ = ReplaceStr(Chr$(7), " ", A$)
PrepareHtml = Replace(A$, vbCrLf, "<br>") ' or you can use <p>
End Function
Public Function HTML(sText As String, _
Optional sContextStart As String = "<HTML><BODY>", _
Optional sContextEnd As String = "</BODY></HTML>") As Byte()
' part of this code from an example from Microsfot
Dim m_sDescription As String
m_sDescription = "Version:1.0" & vbCrLf & _
"StartHTML:aaaaaaaaaa" & vbCrLf & _
"EndHTML:bbbbbbbbbb" & vbCrLf & _
"StartFragment:cccccccccc" & vbCrLf & _
"EndFragment:dddddddddd" & vbCrLf
Dim A() As Byte, b() As Byte, c() As Byte
A() = Utf16toUtf8(sContextStart & "<!--StartFragment -->")
b() = Utf16toUtf8(sText)
c() = Utf16toUtf8("<!--EndFragment -->" & sContextEnd)
Dim sData As String, mdata As Long, eData As Long, fData As Long
eData = UBound(A()) - LBound(A()) + 1
mdata = UBound(b()) - LBound(b()) + 1
fData = UBound(c()) - LBound(c()) + 1
m_sDescription = Replace(m_sDescription, "aaaaaaaaaa", Format(Len(m_sDescription), "0000000000"))
m_sDescription = Replace(m_sDescription, "bbbbbbbbbb", Format(Len(m_sDescription) + eData + mdata + fData, "0000000000"))
m_sDescription = Replace(m_sDescription, "cccccccccc", Format(Len(m_sDescription) + eData, "0000000000"))
m_sDescription = Replace(m_sDescription, "dddddddddd", Format(Len(m_sDescription) + eData + mdata, "0000000000"))
Dim all() As Byte, m() As Byte
ReDim all(Len(m_sDescription) + eData + mdata + fData)
m() = Utf16toUtf8(m_sDescription)
CopyMemory all(0), m(0), Len(m_sDescription)
CopyMemory all(Len(m_sDescription)), A(0), eData
CopyMemory all(Len(m_sDescription) + eData), b(0), mdata
CopyMemory all(Len(m_sDescription) + eData + mdata), c(0), fData
HTML = all()
End Function
Function RegisterCF() As Long
'Register the HTML clipboard format
If (m_cfHTMLClipFormat = 0) Then
m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
End If
RegisterCF = m_cfHTMLClipFormat
End Function
Public Function SimpleHtmlData(ByVal sText As String)
Dim lFormatId As Long, bb() As Byte
lFormatId = RegisterCF
If lFormatId <> 0 Then
If sText = "" Then Exit Function
bb() = HTML(sText)
If CBool(OpenClipboard(0)) Then
Dim hMemHandle As Long, lpData As Long
hMemHandle = GlobalAlloc(0, UBound(bb()) - LBound(bb()) + 10)
If CBool(hMemHandle) Then
lpData = GlobalLock(hMemHandle)
If lpData <> 0 Then
CopyMemory ByVal lpData, bb(0), UBound(bb()) - LBound(bb())
GlobalUnlock hMemHandle
EmptyClipboard
SetClipboardData lFormatId, hMemHandle
End If
End If
Call CloseClipboard
End If
End If
End Function
Private Function SetTextData( _
ByVal lFormatId As Long, _
ByVal sText As String _
) As Boolean
If lFormatId = 0 Then Exit Function
Dim hMem As Long, lPtr As Long
Dim lSize As Long
lSize = LenB(sText)
hMem = GlobalAlloc(0, lSize + 2)
If (hMem > 0) Then
lPtr = GlobalLock(hMem)
CopyMemory ByVal lPtr, ByVal StrPtr(sText), lSize + 1
GlobalUnlock hMem
If (OpenClipboard(0) <> 0) Then
SetClipboardData lFormatId, hMem
CloseClipboard
Else
GlobalFree hMem
End If
End If
End Function
Public Function Utf16toUtf8(s As String) As Byte()
' code from vbforum
' UTF-8 returned to VB6 as a byte array (zero based) because it's pretty useless to VB6 as anything else.
Dim iLen As Long
Dim bbBuf() As Byte
'
iLen = WideCharToMultiByte(Utf8CodePage, 0, StrPtr(s), Len(s), 0, 0, 0, 0)
ReDim bbBuf(0 To iLen - 1) ' Will be initialized as all &h00.
iLen = WideCharToMultiByte(Utf8CodePage, 0, StrPtr(s), Len(s), VarPtr(bbBuf(0)), iLen, 0, 0)
Utf16toUtf8 = bbBuf
End Function
Public Function SpellUnicode(A$)
' use spellunicode to get numbers in Immediate Mode ? SpellUnicode("Γιώργος Καρράς") 'Greek Letters
' and make a ListenUnicode...with numbers for input text
' You can see that if you have Arial Greek
' ? ListenUnicode(915,953,974,961,947,959,962,32,922,945,961,961,940,962)
Dim b$, i As Long
For i = 1 To Len(A$) - 1
b$ = b$ & CStr(AscW(Mid$(A$, i, 1))) & ","
Next i
SpellUnicode = b$ & CStr(AscW(Right$(A$, 1)))
End Function
Public Function ListenUnicode(ParamArray aa() As Variant) As String
Dim all$, i As Long
For i = 0 To UBound(aa)
all$ = all$ & ChrW(aa(i))
Next i
ListenUnicode = all$
End Function