ひできちの楽天ブログ

 


'  WinAPI 方式（DataObject が使えない環境用）
'-----------------------------------------------------------
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
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 CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As LongPtr, _
ByRef Source As Any, _
ByVal Length As LongPtr)
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByVal Destination As Long, _
ByRef Source As Any, _
ByVal Length As Long)
#End If

Const CF_TEXT As Long = 1
Const GMEM_MOVEABLE As Long = &H2

Const TABLE_HTML_TAG_OPEN As String = "<table>"
Const TABLE_HTML_TAG_CLOSE As String = "</table>"
Const TR_HTML_TAG_OPEN As String = "<tr>"
Const TR_HTML_TAG_CLOSE As String = "</tr>"
Const TD_HTML_TAG_OPEN As String = "<td>"
Const TD_HTML_TAG_CLOSE As String = "</td>"

Const AMP_HTML_ENCODE As String = "&" & "amp;"
Const LT_HTML_ENCODE As String = "&" & "lt;"
Const GT_HTML_ENCODE As String = "&" & "gt;"
Const DOUBLE_QUOT_HTML_ENCODE As String = "&" & "quot;"
Const SINGLE_QUOT_HTML_ENCODE As String = "&" & "#39;"
'===========================================================
' クリップボードコピー（DataObject → 失敗時は WinAPI）
'===========================================================

Public Sub CopyToClipboard(ByVal text As String)
If TryCopyByDataObject(text) Then
Exit Sub
End If
CopyByWinAPI text
End Sub


'-----------------------------------------------------------
' ① DataObject 方式（標準・最優先）
'-----------------------------------------------------------
Private Function TryCopyByDataObject(ByVal text As String) As Boolean
On Error GoTo ErrHandler

Dim obj As Object
Set obj = CreateObject("MSForms.DataObject")
obj.SetText text
obj.PutInClipboard

TryCopyByDataObject = True
Exit Function

ErrHandler:
TryCopyByDataObject = False
End Function

Private Sub CopyByWinAPI(ByVal text As String)
Dim hMem As LongPtr
Dim pMem As LongPtr
Dim s As String
Dim cb As Long

' 改行を CRLF に統一（HTML なら不要だが念のため）
s = text & vbNullChar

' Unicode のバイト数
cb = LenB(s)

' メモリ確保
hMem = GlobalAlloc(&H2, cb)
If hMem = 0 Then Exit Sub

' ロックしてポインタ取得
pMem = GlobalLock(hMem)
If pMem = 0 Then Exit Sub

' 文字列をコピー
CopyMemory ByVal pMem, ByVal StrPtr(s), cb

' アンロック
GlobalUnlock hMem

' クリップボードへ
If OpenClipboard(0) Then
EmptyClipboard
SetClipboardData 13, hMem   ' CF_UNICODETEXT = 13
CloseClipboard
End If
End Sub

Private Function HtmlEncode(ByVal s As String) As String
s = Replace(s, "&", AMP_HTML_ENCODE)
s = Replace(s, "<", LT_HTML_ENCODE)
s = Replace(s, ">", GT_HTML_ENCODE)
s = Replace(s, """", DOUBLE_QUOT_HTML_ENCODE)
s = Replace(s, "'", SINGLE_QUOT_HTML_ENCODE)
HtmlEncode = s
End Function


'改行なしバージョン
Sub SelectionToHtmlTableWithoutWrap_Clipboard()

Dim html As String
Dim r As Long, c As Long, v

html = TABLE_HTML_TAG_OPEN

' 対象範囲
If TypeName(Selection) <> "Range" Then
MsgBox "セル範囲を選択してください。", vbExclamation
Exit Sub
End If
Set rng = Selection

For r = 1 To rng.Rows.Count
html = html & TR_HTML_TAG_OPEN
For c = 1 To rng.Columns.Count
v = HtmlEncode(rng.Cells(r, c).text)
html = html & TD_HTML_TAG_OPEN & v & TD_HTML_TAG_CLOSE
Next c
html = html & TR_HTML_TAG_CLOSE
Next r

html = html & TABLE_HTML_TAG_CLOSE

CopyToClipboard html

MsgBox "改行なしのHTMLテーブルソースコードをクリップボードにコピーしました。", vbInformation

End Sub




'改行ありバージョン
Sub SelectionToHtmlTable_Clipboard()

Dim rng As Range
Dim r As Long, c As Long
Dim html As String
Dim v
Dim objData As Object

' 対象範囲
If TypeName(Selection) <> "Range" Then
MsgBox "セル範囲を選択してください。", vbExclamation
Exit Sub
End If
Set rng = Selection

' HTMLテーブル生成
html = TABLE_HTML_TAG_OPEN & vbCrLf

For r = 1 To rng.Rows.Count
html = html & TR_HTML_TAG_OPEN & vbCrLf
For c = 1 To rng.Columns.Count
v = HtmlEncode(rng.Cells(r, c).text)
html = html & TD_HTML_TAG_OPEN & v & TD_HTML_TAG_CLOSE & vbCrLf
Next c
html = html & TR_HTML_TAG_CLOSE & vbCrLf
Next r

html = html & TABLE_HTML_TAG_CLOSE

' クリップボードへ格納
'動作しない！！！！
'参照設定が必要！
'Microsoft Forms 2.0 Object Library
'Set objData = CreateObject("MSForms.DataObject")
'objData.SetText html
'objData.PutInClipboard

CopyToClipboard html

MsgBox "改行ありのHTMLテーブルソースコードをクリップボードにコピーしました。", vbInformation


End Sub