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
