LoginSignup
2
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@csigesnpb

VBAでクリップボードにHTMLテキストをコピーする

Posted at

HTMLテキストのクリップボード形式

HTMLテキストのクリップボード形式（形式名：HTML Format）はテキストデータですが、ヘッダを付ける点と文字エンコードがUTF-8である点で通常のテキストと異なるようです。また、テキストは部分的なHTMLでなく、フラグメントとコンテキストに分けて記録します。

  • フラグメント：主要な（選択した）HTML要素
  • コンテキスト：フラグメントの周囲の関係するタグも含めたHTML要素（<HTML> ～ </HTML>）

下記はEdgeでQiitaを開いてアドレスバーからコピーした際のクリップボードですが、クリップボードのバージョン番号やコンテキストとフラグメントの開始位置と終了位置を含めたヘッダがあり、またaタグを<!--StartFragment-->と<!--EndFragment-->で囲む構造をしています。

Version:0.9
StartHTML:0000000105
EndHTML:0000000215
StartFragment:0000000141
EndFragment:0000000179
<html>
<body>
<!--StartFragment--><a href="https://qiita.com/">Qiita</a><!--EndFragment-->
</body>
</html>

VBAはバイナリ操作もUTF-8エンコードも不得意なので Windows API と ADODB.Stream オブジェクトを利用してコードを記述しました。コードの複雑化を避けるためオフセットの計算はマジックナンバーとしています。

VBAコード

クリップボードへHTML形式テキストのコピーと読み取り

VBA
' クリップボード操作関数
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long

' メモリ管理関数
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr
Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongLong)
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long

' 文字列操作関数
Private Declare PtrSafe Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As LongPtr) As Long


' クリップボードにaタグをコピーして取得します
Public Sub SetClipboardTest()
    SetClipboardHTML "https://qiita.com", "<a href=""https://qiita.com/"">Qiita</a>"
    Debug.Print GetClipbordHTML
End Sub


' クリップボードにテキストとHTMLテキストをコピーします、成否を返します
Private Function SetClipboardHTML(sText As String, sHtml As String) As Boolean
    Const GHND As Long = &H42
    Const CF_UNICODETEXT As Long = 13
    
    ' 新しいクリップボード形式を登録します
    Dim CF_HTML As Long: CF_HTML = RegisterClipboardFormat("HTML Format")
    If CF_HTML = 0 Then Exit Function
    
    ' クリップボードを開きます
    If OpenClipboard(0) = 0 Then Exit Function ' クリップボードを開くのに失敗
    On Error GoTo Finally ' エラーが発生したら Close するようにします
    EmptyClipboard
    
    ' テキストをクリップボードにコピーします
    Dim hText As LongPtr: hText = GlobalAlloc(GHND, LenB(sText) + 2)
    If hText = 0 Then GoTo Finally ' 関数に失敗
    Dim pText As LongPtr: pText = GlobalLock(hText)
    If pText = 0 Then GlobalFree hText: GoTo Finally ' 関数に失敗
    MoveMemory pText, StrPtr(sText), LenB(sText)
    GlobalUnlock hText
    If SetClipboardData(CF_UNICODETEXT, hText) = 0 Then
        ' コピー失敗
        GlobalFree hText
        GoTo Finally
    End If
    
    ' HTMLテキストをUTF-8エンコードの文字列でクリップボードにコピーします
    With CreateObject("ADODB.Stream")
        .Type = 2 ' adTypeText
        .Charset = "UTF-8"
        .Open
        .WriteText "Version:0.9" & vbCrLf
        .WriteText "StartHTML:000089" & vbCrLf
        .WriteText "EndHTML:000000" & vbCrLf
        .WriteText "StartFragment:000125" & vbCrLf
        .WriteText "EndFragment:000000" & vbCrLf
        .WriteText "<html>" & vbCrLf
        .WriteText "<body>" & vbCrLf
        .WriteText "<!--StartFragment-->"
        .WriteText sHtml
        .WriteText "<!--EndFragment-->" & vbCrLf
        .WriteText "</body>" & vbCrLf
        .WriteText "</html>"
        .WriteText vbNullChar ' NULL末端
        Dim byteLength As Long: byteLength = CLng(.Position) - 3 ' BOMを除く
        .Position = 84 ' EndFragment:
        .WriteText Format(byteLength - 37, "000000")
        .Position = 42 ' EndHTML:
        .WriteText Format(byteLength - 1, "000000")
        .Position = 0
        .Type = 1 ' adTypeBinary
        .Position = 3 ' BOMを除く
        Dim bytes() As Byte: bytes = .Read
    End With
    Dim hHtml As LongPtr: hHtml = GlobalAlloc(GHND, byteLength)
    If hHtml = 0 Then GoTo Finally ' 関数に失敗
    Dim pHtml As LongPtr: pHtml = GlobalLock(hHtml)
    If pHtml = 0 Then GlobalFree hHtml: GoTo Finally ' 関数に失敗
    MoveMemory pHtml, VarPtr(bytes(0)), byteLength
    GlobalUnlock hHtml
    If SetClipboardData(CF_HTML, hHtml) = 0 Then
        ' コピー失敗
        GlobalFree hHtml
        GoTo Finally
    End If
    SetClipboardHTML = True
    
Finally:
    CloseClipboard
End Function


' クリップボードからHTML形式のテキストを取得します
Private Function GetClipbordHTML() As String
    If OpenClipboard(0) = 0 Then Exit Function ' クリップボードを開くのに失敗
    On Error GoTo Finally ' エラーが発生したら Close するようにします
Continue:
    ' クリップボード形式を列挙します
    Dim cf As Long: cf = EnumClipboardFormats(cf)
    
    ' 戻り値が 0 の場合は列挙終了
    If cf = 0 Then GoTo Finally
    
    ' 標準のクリップボード形式の場合は次へ
    If cf < &HC000& Then GoTo Continue
    
    ' クリップボード形式名を取得します
    Dim cfName As String * 100
    If GetClipboardFormatName(cf, cfName, LenB(cfName)) = 0 Then GoTo Finally
    
    ' クリップボード形式名が HTML Format でない場合は次へ
    If Left(cfName, InStr(cfName, vbNullChar) - 1) <> "HTML Format" Then GoTo Continue
    
    ' ハンドルを取得します
    Dim hMem As LongPtr: hMem = GetClipboardData(cf)
    If hMem = 0 Then GoTo Finally ' 関数が失敗
    
    ' メモリアドレスを取得します
    Dim pMem As LongPtr: pMem = GlobalLock(hMem)
    If pMem = 0 Then GoTo Finally ' 関数が失敗
    
    ' 文字列のバイト数を取得します
    Dim sLength As Long: sLength = lstrlen(pMem)
    If sLength <= 0 Then GoTo Finally ' 関数が失敗
    
    ' バッファにUTF-8エンコードテキストをコピーします
    Dim sBuffer() As Byte: ReDim sBuffer(1 To sLength)
    MoveMemory VarPtr(sBuffer(1)), pMem, sLength
    
    ' UTF-8からUnicodeに変換します
    With CreateObject("ADODB.Stream")
        .Type = 1 ' adTypeBinary
        .Open
        .Write sBuffer
        .Position = 0
        .Type = 2 ' adTypeText
        .Charset = "UTF-8"
        GetClipbordHTML = .ReadText
    End With
    
Finally:
    If pMem Then GlobalUnlock hMem
    CloseClipboard
End Function

クリップボード内のデータ形式を列挙

おまけ

VBA
' クリップボード操作関数
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long


' イミディエイトウィンドウにクリップボード形式を列挙する
Public Sub PrintClipboardFormats()
    OpenClipboard 0
    Do
        Dim cf As Long: cf = EnumClipboardFormats(cf)
        If cf = 0 Then Exit Do
        If cf < &HC000& Then
            Dim cfName As String
            Select Case cf
                Case 1: cfName = "CF_TEXT"
                Case 2: cfName = "CF_BITMAP"
                Case 3: cfName = "CF_METAFILEPICT"
                Case 4: cfName = "CF_SYLK"
                Case 5: cfName = "CF_DIF"
                Case 6: cfName = "CF_TIFF"
                Case 7: cfName = "CF_OEMTEXT"
                Case 8: cfName = "CF_DIB"
                Case 9: cfName = "CF_PALETTE"
                Case 9: cfName = "CF_PALETTE"
                Case 11: cfName = "CF_RIFF"
                Case 12: cfName = "CF_WAVE"
                Case 13: cfName = "CF_UNICODETEXT"
                Case 14: cfName = "CF_ENHMETAFILE"
                Case 15: cfName = "CF_HDROP"
                Case 16: cfName = "CF_LOCALE"
                Case 17: cfName = "CF_DIBV5"
                Case &H80&: cfName = "CF_OWNERDISPLAY"
                Case &H81&: cfName = "CF_DSPTEXT"
                Case &H82&: cfName = "CF_DSPBITMAP"
                Case &H83&: cfName = "CF_DSPMETAFILEPICT"
                Case &H8E&: cfName = "CF_DSPENHMETAFILE"
                Case &H82&: cfName = "CF_GDIOBJFIRST"
                Case &H200&: cfName = "CF_PRIVATEFIRST"
                Case &H2FF&: cfName = "CF_PRIVATELAST"
                Case &H300&: cfName = "CF_DSPBITMAP"
                Case &H300&: cfName = "CF_DSPBITMAP"
                Case &H300&: cfName = "CF_DSPBITMAP"
                Case &H3FF&: cfName = "CF_GDIOBJLAST"
                Case Else: cfName = "--Unknown--"
            End Select
        Else
            Dim sBuffer As String * 255: If GetClipboardFormatName(cf, sBuffer, LenB(sBuffer)) = 0 Then Exit Do
            cfName = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
        End If
        Debug.Print Right("000" & WorksheetFunction.Dec2Hex(cf), 4), cfName
    Loop
    CloseClipboard
End Sub

参考

2
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
2
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?