Option Explicit
' Written: May 02, 2018
' Author: Leith Ross
' Summary: Copies a fragment of HTML code to the clipboard in HTML format.
' This allows the system to render the HTML code as you would see it on the wewb page.
' // API calls for use with WoW64 systems. If this code fails to compile then you have a 32 bit OS.
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function strLen Lib "kernel32.dll" Alias "lstrlenA" (ByVal lpData As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef pDest As Any, ByRef pSource As Any, ByVal cbLength As Long)
Private Const htmlHeader = _
"Version:1.0" & vbCrLf & _
"StartHTML:aaaaaaaaaa" & vbCrLf & _
"EndHTML:bbbbbbbbbb" & vbCrLf & _
"StartFragment:cccccccccc" & vbCrLf & _
"EndFragment:dddddddddd" & vbCrLf
' // HTML Clipboard Format
Private cfHTML As LongPtr
Function RegisterCF() As Long
' // Register the HTML clipboard format
If cfHTML = 0 Then
cfHTML = RegisterClipboardFormat("HTML Format")
End If
RegisterCF = cfHTML
End Function
Public Sub CopyHtmlToClipboard(ByVal strHtmlFragment As String)
Dim htmlEndTags As String
Dim htmlStartTags As String
Dim strData As String
Dim hMem As LongPtr
Dim lpData As LongPtr
If RegisterCF = 0 Then Exit Sub
htmlStartTags = "<HTML>******>"
htmlEndTags = "</BODY></HTML>"
' // Add the starting and ending tags for the HTML fragment
htmlStartTags = htmlStartTags & "<!--StartFragment -->"
htmlEndTags = "<!--EndFragment -->" & htmlEndTags
' // Build the HTML given the description, the fragment and the context.
' // And, replace the offset place holders in the description with values
' // for the offsets of StartHMTL, EndHTML, StartFragment and EndFragment.
strData = htmlHeader & htmlStartTags & strHtmlFragment & htmlEndTags
strData = Replace(strData, "aaaaaaaaaa", Format(Len(htmlHeader), "0000000000"))
strData = Replace(strData, "bbbbbbbbbb", Format(Len(strData), "0000000000"))
strData = Replace(strData, "cccccccccc", Format(Len(htmlHeader & htmlStartTags), "0000000000"))
strData = Replace(strData, "dddddddddd", Format(Len(htmlHeader & htmlStartTags & strHtmlFragment), "0000000000"))
' // Add the HTML code to the clipboard
If OpenClipboard(0) <> 0 Then
hMem = GlobalAlloc(0, Len(strData) + 10)
If hMem <> 0 Then
lpData = GlobalLock(hMem)
If lpData <> 0 Then
CopyMemory ByVal lpData, ByVal strData, Len(strData)
GlobalUnlock hMem
EmptyClipboard
SetClipboardData cfHTML, hMem
End If
End If
Call CloseClipboard
End If
End Sub
Public Function GetHTMLClipboard() As String
Dim hMemHandle As Long
Dim lpData As Long
Dim nClipSize As Long
Dim nStartFrag As Long
Dim nEndFrag As Long
Dim nIndex As Long
Dim sData As String
If RegisterCF = 0 Then Exit Function
If OpenClipboard(0) <> 0 Then
GlobalUnlock hMemHandle
' // Retrieve the data from the clipboard
hMemHandle = GetClipboardData(cfHTML)
If hMemHandle <> 0 Then
lpData = GlobalLock(hMemHandle)
If lpData <> 0 Then
nClipSize = strLen(lpData)
sData = String(nClipSize + 10, 0)
Call CopyMemory(ByVal sData, ByVal lpData, nClipSize)
' // If StartFragment appears in the data's description,
' // then retrieve the offset specified in the description
' // for the start of the fragment. Likewise, if EndFragment
' // appears in the description, then retrieve the
' // corresponding offset.
nIndex = InStr(sData, "StartFragment:")
If nIndex Then
nStartFrag = CLng(Mid(sData, nIndex + Len("StartFragment:"), 10))
End If
nIndex = InStr(sData, "EndFragment:")
If nIndex Then
nEndFrag = CLng(Mid(sData, nIndex + Len("EndFragment:"), 10))
End If
' // Return the fragment given the starting and ending
' // offsets
If (nStartFrag > 0 And nEndFrag > 0) Then
GetHTMLClipboard = Mid(sData, nStartFrag + 1, (nEndFrag - nStartFrag))
End If
End If
End If
Call CloseClipboard
End If
End Function