Zoople HTML5 Control ActiveX for VB and ACCESS

some glitches in the Zoople ActiveX documentation, to whome ever it concerns

documentation is not very efficient and short

ZOOPLE

How to set H1, H2, …… on a Button

Call ZoopleHTML.ExecCommand(“formatblock”, False, “<h1>”)

How to remove H1, H2, …..

Call ZoopleHTML.ExecCommand(“formatblock”, False, “<p>”)

How to set a bullet as format

ZoopleHTML.ExecCommand “insertunorderedlist”

how to paste a Picture from a file

Private Sub bPasteImage_Click()
Const TempFN = “d:\temp\temp_heli_paste_pic.jpb”
Dim s As String
s = Base64ImageFromFile(TempFN) ‘the helper function down below
Me.Zoople.InsertAtCursor (s)
End Sub

Additional Functions useful for dealing with Zoople

If your Charset does not fit – Conversion Routines (e.g. Deutsche Umlaute usw)

Function Ascii2HTML(ByVal s As String) As String
Ascii2HTML = UnicodeToISO_8859_1(s)
End Function

Function Ascii2Unicode(ByVal s As String) As String
Ascii2Unicode = UnicodeToISO_8859_1(s)
End Function

Function HTML2Ascii(ByVal s As String) As String ‘utf, unicode, Ansii
HTML2Ascii = UnicodeToISO_8859_1(s)
End Function

‘https://docs.microsoft.com/en-us/previous-versions/exchange-server/exchange-10/ms526296(v=exchg.10)

Function UnicodeToISO_8859_1(ByVal Text As String) As String
Dim objStream As Object
Const adTypeBinary = 1
Const adTypeText = 2

On Error GoTo x

Set objStream = CreateObject(“ADODB.Stream”)

objStream.Type = adTypeText
objStream.Charset = “UTF-8”
‘objStream.Charset = “iso-8859-15”
‘objStream.Charset = “iso-14289-1”
objStream.Open

‘Text in Stream schreiben
objStream.WriteText Text
objStream.Flush
objStream.Position = 0
‘objStream.Charset = “UTF-8”
objStream.Charset = “iso-8859-15″

objStream.Type = adTypeBinary

If err Then
UnicodeToISO_8859_1 = Null
Else
UnicodeToISO_8859_1 = Mid(StrConv(objStream.Read, vbUnicode), 4, 10000)
End If

objStream.Close
Exit Function
x:
MsgBox CStr(err.Number) + ” ” + err.Description
End Function

‘https://docs.microsoft.com/en-us/previous-versions/exchange-server/exchange-10/ms526296(v=exchg.10)

Function ISO_8859_1_to_Unicode(ByVal Text As String) As String
Dim objStream As Object
Const adTypeBinary = 1
Const adTypeText = 2

On Error GoTo x

Set objStream = CreateObject(“ADODB.Stream”)
objStream.Type = adTypeText
‘objStream.Charset = “UTF-8”
objStream.Charset = “iso-8859-15”
‘objStream.Charset = “iso-14289-1”
‘objStream.Charset = “Windows-1252”
objStream.Open

‘Text in Stream schreiben
objStream.WriteText Text
objStream.Flush
objStream.Position = 0
objStream.Charset = “UTF-8”
‘objStream.Charset = “iso-8859-15″

objStream.Type = adTypeBinary

If err Then
ISO_8859_1_to_Unicode = Null
Else
ISO_8859_1_to_Unicode = Mid(StrConv(objStream.Read, vbUnicode), 4, 10000)
End If

objStream.Close
Exit Function
x:
MsgBox CStr(err.Number) + ” ” + err.Description
End Function

How to Convert HTML2Text

Function Html2Text(HTML As String, Optional RemoveLF As Boolean = False) As String
‘ Erstellen Sie ein HTML-Dokument-Objekt
Dim s As String, i As Long, Doc as object
s = HTML
Dim doc As MSHTML.HTMLDocument
Set doc = New MSHTML.HTMLDocument

‘ Setzen Sie den HTML-Code
doc.Body.innerHTML = s

‘ Extrahieren Sie den Text aus dem HTML-Dokument
s = doc.Body.innerText

If RemoveLF Then s = replace(s, vbCrLf, “|”)

If s <> “” Then s = TrimAll(TrimAll(s))
Html2Text = s
Set doc = Nothing
End Function

Text2HTML

Function Text2HTML(ByVal s As String) As String
Dim ss As String, a() As String, i As Long
a = Split(s, vbCrLf)
For i = 0 To UBound(a)
a(i) = “<p>” + a(i) + “</p>”
Next
Text2HTML = Join(a, vbCrLf)
End Function

how to paste a Picture from a file

Private Sub bPasteImage_Click()
Const TempFN = “d:\temp\temp_heli_paste_pic.jpb”
Dim s As String
s = Base64ImageFromFile(TempFN)
Me.eHTML.InsertAtCursor (s)
End Sub

‘opens a JPG File and creates a valid Base64 encoded HTML-IMG Field
Public Function Base64ImageFromFile(FN As String) As String
Dim s As String
Const img = “<img src=’data:image/jpg;base64, XXX==’ alt=’pasted image’ />”
s = Base64Encode_Imagefile(TempClipPictFN)
Base64ImageFromFile = replace(img, “XXX”, s)
End Function

‘need to add library link: Microsoft XML 3.0 and ActiveX Data Object 6.1

‘opens a JPG File and Base64 encodes
Public Function Base64Encode_Imagefile(s As String) As String
Dim Bytes ‘As String ‘, b64
With CreateObject(“ADODB.Stream”)
.Open
.Type = ADODB.adTypeBinary
.LoadFromFile s
Bytes = .Read
.Close
End With
Base64Encode_Imagefile = EncodeBase64(Bytes)
End Function

Public Function EncodeBase64(Bytes) As String
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement(“b64”)
objNode.DataType = “bin.base64”
objNode.nodeTypedValue = Bytes
EncodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function

Set Any HTML-Code into Clipboard (without Zoople Editor)

Public Function SetClipboardHTML(HTML As String, Optional SourceURL As String = “https://www.ganzemedizin.at”)
Dim s As String, i As Long, j As Long, ss As String
Const c = “Version:0.9” + vbCrLf + “StartHTML:0000000541” + vbCrLf + “EndHTML:0000007048” + vbCrLf + “StartFragment:0000000577” + vbCrLf + “EndFragment:0000007012” + “SourceURL:dddd”
s = “Version:0.9” + vbCrLf + “StartHTML:§AAA§” + vbCrLf + “EndHTML:§BBB§” + vbCrLf
s = s + “StartFragment:§CCC§” + vbCrLf + “EndFragment:§DDD§” + vbCrLf + “SourceURL:§EEE§” + vbCrLf
s = s + “<html>” + vbCrLf + “<body>” + vbCrLf + “<!–StartFragment–>”
s = s + “§FFF§” + “<!–EndFragment–>” + vbCrLf + “</body>” + vbCrLf + “</html>”
s = replace(s, “§EEE§”, SourceURL)
s = replace(s, “§FFF§”, HTML)
i = InStr(s, “<html>”) – 1
ss = Format(i, “0000000000”)
s = replace(s, “§AAA§”, ss)
i = InStr(s, “</html>”) + 7
ss = Format(i, “0000000000”)
s = replace(s, “§BBB§”, ss)
i = InStr(s, “<!–StartFragment–>”)
ss = Format(i, “0000000000”)
s = replace(s, “§CCC§”, ss)
i = InStr(s, “<!–EndFragment–>”) + Len(“<!–EndFragment–>”)
ss = Format(i, “0000000000”)
s = replace(s, “§DDD§”, ss)
Debug.Print s
Call SetClipboardData(s, False, True)
End Function

Function SetClipboardData(strText As String, Optional RTF As Boolean = False, Optional HTML As Boolean = False) As Boolean
‘ Comments : Writes the supplied string to the clipboard
‘ Parameters: strText – text to write
‘ Returns : True if successful, False otherwise
‘
Dim lngHoldMem As Long
Dim lngGlobalMem As Long
Dim lngClipMem As Long
Dim lngTmp As Long

On Error GoTo SetClipboardData_ERR

If RTF Then
Call RegistRTF
End If
If HTML Then
Call RegistHTML
End If

‘ Allocate moveable global memory.
lngHoldMem = TSB_API_GlobalAlloc(GHND, Len(strText) + 1)

‘ Lock the block to get a far pointer to this memory.
lngGlobalMem = TSB_API_GlobalLock(lngHoldMem)

‘ Copy the string to this global memory.
lngGlobalMem = TSB_API_lstrCopy(lngGlobalMem, strText)

‘ Unlock the memory.
If TSB_API_GlobalUnlock(lngHoldMem) = 0 Then

‘ Open the Clipboard to copy data to.
If TSB_API_OpenClipboard(0&) <> 0 Then

‘ Clear the Clipboard.
lngTmp = TSB_API_EmptyClipBoard()

‘ Copy the data to the Clipboard.
‘ lngClipMem = TSB_API_SetClipboardData(CF_RTFTEXT, lngHoldMem)
If RTF Then
lngClipMem = TSB_API_SetClipboardData(cfRTF, lngHoldMem)
Else
If HTML Then
lngClipMem = TSB_API_SetClipboardData(cfHTML, lngHoldMem)
Else
lngClipMem = TSB_API_SetClipboardData(CF_TEXT, lngHoldMem)
End If
End If
lngTmp = TSB_API_CloseClipboard()
End If
End If

SetClipboardData = True

SetClipboardData_EXIT:
Exit Function

SetClipboardData_ERR:
SetClipboardData = False
Resume SetClipboardData_EXIT

End Function

for Setting Clipboard-data as HTML or RTF is enough in internet available

Function RegistHTML() As Long
On Error GoTo er
cfHTML = RegisterClipboardFormat(CF_HTML)
er:
End Function

Function RegistRTF() As Long
On Error GoTo er
cfRTF = RegisterClipboardFormat(CF_RTF)
er:
End Function

Send Email via SMTP with correct “deutsche Umlaute”

Function SendMailSimpleText(ToAddress As String, Optional Subject As String = “Mail from xxxx”, Optional Body As String = “Automail aus dem Praxisprogramm von Dr. Retzek”) As Boolean
‘ Konstanten für Konfiguration
Const cdoSendUsingPort = 2
Const cdoBasic = 1
Const schema = “http://schemas.microsoft.com/cdo/configuration/”

‘ E-Mail-Objekt und Konfigurationsobjekt erstellen
Dim ObjMessage As Object
Set ObjMessage = CreateObject(“CDO.Message”)
Dim iConf As Object
Set iConf = CreateObject(“CDO.Configuration”)

‘ Konfigurationsfelder setzen
With iConf.Fields
.item(schema & “sendusing”) = cdoSendUsingPort
.item(schema & “smtpserver”) = “your SMTP-Server” ‘ Setzen Sie Ihren SMTP-Server
.item(schema & “smtpserverport”) = 25 ‘ oder 465/587 je nach Server
.item(schema & “smtpauthenticate”) = cdoBasic
.item(schema & “sendusername”) = “your account”
.item(schema & “sendpassword”) = “your password”
.item(schema & “smtpusessl”) = True ‘ oder False, abhängig von Ihrem SMTP-Server
‘ Wichtig: Setzen des Charset auf UTF-8 für den Body
.item(schema & “charset”) = “utf-8”

.Update
End With
Debug.Print Body
‘ Nachricht konfigurieren
With ObjMessage
Set .Configuration = iConf
.To = ToAddress
.From = “postausgang@ganzemedizin.at”
.Subject = Subject
.BodyPart.Charset = “iso-8859-1” ‘für die deutschen Umlaute
.TextBody = Body
‘Debug.Print EncodeBase64(Body)
‘ Setzen Sie den ContentType auf text/plain und Charset auf utf-8
.Fields(schema & “content-type”) = “text/plain;charset=utf-8”
.Fields(schema & “content-transfer-encoding”) = “base64”
.Fields.Update
End With

‘ E-Mail senden
On Error Resume Next
ObjMessage.Send

‘ Fehlerbehandlung und Aufräumen
If err.Number = 0 Then
SendMailSimpleText = True
Else
SendMailSimpleText = False
MsgBox “Fehler beim Senden der E-Mail: ” & err.Description
End If
Set ObjMessage = Nothing
Set iConf = Nothing
End Function

Deutsche Umlaute korrigieren

Function ReplaceUmlaute(ByVal s As String) As String
s = replace(s, “Ü”, “UE”)
s = replace(s, “ü”, “ue”)
s = replace(s, “ö”, “oe”)
s = replace(s, “Ö”, “OE”)
s = replace(s, “Ä”, “AE”)
s = replace(s, “ä”, “ae”)
s = replace(s, “ß”, “ss”)
ReplaceUmlaute = s
End Function