Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_DDESHARE As Long = &H2000
Private Const CF_UNICODETEXT = 13
Private Const CP_UTF8 = 65001
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, ByVal dwFlags As Long, _
lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As String, _
ByVal cchWideChar As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Function RangeToHTML(rng As Range) As String
Dim text As String, format As Long, m() As Byte, hData As Long, pData As Long, size As Long, index As Long, start As Long, formatname As String
Dim strSize As Long
On Error Resume Next
' copy range vao Clipboard
rng.Copy
If OpenClipboard(0) = 0 Then Exit Function
format = EnumClipboardFormats(0)
Do While format > 0
formatname = String(64, Chr(0))
size = GetClipboardFormatName(format, formatname, 64)
formatname = Left(formatname, size)
If formatname = "HTML Format" Then
' trong ClipBoard có Format - HTML Format, vậy ta đọc Handle của Data
hData = GetClipboardData(format)
If hData = 0 Then MsgBox GetLastError
' muốn đọc Data thì trước hết phải có "địa chỉ" của Data trong RAM - đọc ra bằng hàm GlobalLock
pData = GlobalLock(hData)
' độ lớn của Data đọc ra bằng hàm GlobalSize
size = GlobalSize(hData)
' chuẩn bị mảng có độ lớn thích hợp để đọc Data
' ReDim m(0 To size - 1)
'' chép toàn bộ Data vào mảng
' CopyMemory m(0), ByVal pData, size
'
' strSize = MultiByteToWideChar(CP_UTF8, 0, m(0), size, vbNullString, 0)
' text = String(2 * strSize, Chr(0))
' MultiByteToWideChar CP_UTF8, 0, m(0), size, text, strSize
strSize = MultiByteToWideChar(CP_UTF8, 0, ByVal pData, size, vbNullString, 0)
text = String(2 * strSize, Chr(0))
MultiByteToWideChar CP_UTF8, 0, ByVal pData, size, text, strSize
' cuối cùng là UnLock
GlobalUnlock hData
' lọc nội dung HTML
text = StrConv(text, vbFromUnicode)
text = WideStrToWebStringUTF(text)
index = InStr(1, text, ":", vbTextCompare)
index = InStr(index + 1, text, ":", vbTextCompare)
' vị trí mà từ đó bắt đầu nội dung HTML
start = CLng(Mid(text, index + 1, InStr(index, text, vbCr) - index)) + 1
' lấy nội dung HTML
RangeToHTML = Mid(text, start)
Exit Do
End If
format = EnumClipboardFormats(format)
Loop
CloseClipboard
Application.CutCopyMode = False
End Function
Function WideStrToWebStringUTF(ByVal text As String) As String
Dim slowo As Integer, index As Long, c As String, s As String
If Len(text) Then
For index = 1 To Len(text)
c = Mid(text, index, 1)
If AscW(c) < &H80 Then
s = s & c
Else
s = s & "&#" & AscW(c) & ";"
End If
Next index
End If
WideStrToWebStringUTF = s
End Function
