Word VBAにおいて、`Table`オブジェクトは`Rows`コレクションと`Columns`コレクションを持つが、実際のデータは`Cells`コレクションによって管理される。そして、結合セルは`Cell.MergeCells`プロパティが`True`となり、その`Cell.Row.Index`や`Cell.Column.Index`が、見かけ上のグリッド位置とは異なる振る舞いを示すことがある。
‘ ヘルパー関数: HTML特殊文字のエスケープ処理
Private Function HtmlEncode(ByVal str As String) As String
str = Replace(str, “&”, “&”)
str = Replace(str, “<", "<")
str = Replace(str, ">“, “>”)
str = Replace(str, “”””, “"”)
‘ その他のエスケープが必要な場合はここに追加
HtmlEncode = str
End Function
‘ WordのTableオブジェクトをHTMLテーブル文字列に変換する関数
Public Function ConvertWordTableToHtml(ByVal targetTable As Word.Table) As String
Dim htmlBuilder As New Collection ‘ 高速な文字列連結のためCollectionを使用
Dim iRow As Long, iCol As Long
Dim numRows As Long, numCols As Long
Dim cellContent As String
Dim cell As Word.Cell
Dim rowSpanCount As Long, colSpanCount As Long
Dim processedCells() As Boolean ‘ 仮想グリッド: 結合セルが既に処理されたか追跡
On Error GoTo ErrorHandler
If targetTable Is Nothing Then
ConvertWordTableToHtml = “”
Exit Function
End If
‘ テーブルの行数と列数を取得 (見かけ上の最大値)
‘ Cells.Count をRows.Countで割っても正確な列数にならない場合があるため、
‘ 最大列数を持つ行から取得するのが確実。
numRows = targetTable.Rows.Count
numCols = 0
For Each row In targetTable.Rows
If row.Cells.Count > numCols Then
numCols = row.Cells.Count
End If
Next row
‘ 仮想グリッドの初期化
ReDim processedCells(1 To numRows, 1 To numCols)
”
For iCol = 1 To numCols
‘ 既に結合セルの一部として処理済みの場合はスキップ
If processedCells(iRow, iCol) Then
GoTo NextCell
End If
‘ Cellオブジェクトの取得
On Error Resume Next ‘ 結合セルによってCell(iRow, iCol)がエラーになる場合がある
Set cell = targetTable.Cell(iRow, iCol)
On Error GoTo ErrorHandler ‘ エラーハンドラを戻す
‘ 現在のセルが結合セルの一部であるかを確認
If cell.MergeCells Then
‘ 横方向の結合 (colspan)
Dim currentCell As Word.Cell
Set currentCell = cell
Dim nextCell As Word.Cell
‘ 同じ行で右隣のセルが結合されている限りカウント
Do While (iCol + colSpanCount) <= numCols
On Error Resume Next
Set nextCell = targetTable.Cell(iRow, iCol + colSpanCount)
On Error GoTo ErrorHandler
If Not nextCell Is Nothing And nextCell.MergeCells And nextCell.Range.Start = currentCell.Range.Start Then
colSpanCount = colSpanCount + 1
Else
Exit Do
End If
Loop
' 縦方向の結合 (rowspan)
' 同じ列で下隣のセルが結合されている限りカウント
Do While (iRow + rowSpanCount) <= numRows
On Error Resume Next
Set nextCell = targetTable.Cell(iRow + rowSpanCount, iCol)
On Error GoTo ErrorHandler
If Not nextCell Is Nothing And nextCell.MergeCells And nextCell.Range.Start = currentCell.Range.Start Then
rowSpanCount = rowSpanCount + 1
Else
Exit Do
End If
Loop
End If
' 仮想グリッドに処理済みマークを付ける
Dim r As Long, c As Long
For r = iRow To iRow + rowSpanCount - 1
For c = iCol To iCol + colSpanCount - 1
If r <= numRows And c <= numCols Then
processedCells(r, c) = True
End If
Next c
Next r
' セルコンテンツの取得とエスケープ
cellContent = Trim(cell.Range.Text)
' 最終文字の Chr(13) (改行コード) を削除
If Len(cellContent) > 0 And Right(cellContent, 1) = Chr(13) Then
cellContent = Left(cellContent, Len(cellContent) – 1)
End If
cellContent = HtmlEncode(cellContent)
‘ HTML要素の追加
Dim tdTag As String
tdTag = “ 1 Then tdTag = tdTag & ” colspan=””” & colSpanCount & “”””
If rowSpanCount > 1 Then tdTag = tdTag & ” rowspan=””” & rowSpanCount & “”””
tdTag = tdTag & “>” & cellContent & “
”
htmlBuilder.Add tdTag
End If
Set cell = Nothing ‘ オブジェクトの明示的な解放
NextCell:
Next iCol
htmlBuilder.Add “
”
Next iRow
htmlBuilder.Add “
”
htmlBuilder.Add “
”
‘ Collectionの要素を連結して最終的なHTML文字列を生成
Dim item As Variant
For Each item In htmlBuilder
ConvertWordTableToHtml = ConvertWordTableToHtml & item
Next item
Exit Function
ErrorHandler:
MsgBox “エラーが発生しました: ” & Err.Description, vbCritical
ConvertWordTableToHtml = “”
Exit Function
End Function
‘ Windows APIの宣言 (32bit/64bit Office対応)
If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib “user32” (ByVal hwnd As LongPtr) 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 CloseClipboard Lib “user32” () As Long
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 Function lstrcpyW Lib “kernel32” (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr
Private Declare PtrSafe Function GetLastError Lib “kernel32” () As Long
Else
Private Declare Function OpenClipboard Lib “user32” (ByVal hwnd As Long) 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 CloseClipboard Lib “user32” () 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 Function lstrcpyW Lib “kernel32” (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
Private Declare Function GetLastError Lib “kernel32” () As Long
End If
‘ クリップボードフォーマット定数
Private Const CF_UNICODETEXT As Long = 13 ‘ Unicodeテキスト (UTF-16LE)
Private Const GMEM_MOVEABLE As Long = &H2 ‘ メモリブロックが移動可能であることを示す
Private Const GMEM_ZEROINIT As Long = &H40 ‘ メモリをゼロで初期化する
‘ 指定されたテキストをWindowsクリップボードへコピーする関数 (API直接操作版)
Public Function CopyTextToClipboardAPI(ByVal text As String) As Boolean
If VBA7 Then
Dim hMem As LongPtr
Dim lpMem As LongPtr
Else
Dim hMem As Long
Dim lpMem As Long
End If
Dim textLength As Long
Dim success As Boolean
CopyTextToClipboardAPI = False
‘ クリップボードを開く ( hwnd=0 で現在のタスクに関連付け)
If OpenClipboard(0) = 0 Then
Debug.Print “クリップボードを開けませんでした。エラーコード: ” & GetLastError()
Exit Function
End If
‘ クリップボードの内容を空にする
If EmptyClipboard() = 0 Then
Debug.Print “クリップボードを空にできませんでした。エラーコード: ” & GetLastError()
CloseClipboard
Exit Function
End If
‘ グローバルメモリを確保 (GMEM_MOVEABLE: メモリ移動可能, GMEM_ZEROINIT: ゼロ初期化)
hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, textLength)
If hMem = 0 Then
Debug.Print “グローバルメモリの確保に失敗しました。エラーコード: ” & GetLastError()
CloseClipboard
Exit Function
End If
‘ メモリをロックし、ポインタを取得
lpMem = GlobalLock(hMem)
If lpMem = 0 Then
Debug.Print “グローバルメモリのロックに失敗しました。エラーコード: ” & GetLastError()
GlobalUnlock hMem ‘ ロックに失敗しても念のためアンロックを試みる
CloseClipboard
Exit Function
End If
‘ メモリのロックを解除
If GlobalUnlock(hMem) = 0 Then
‘ GlobalUnlockは成功時に0を返すことがあるため、エラーチェックはやや特殊
If GetLastError() <> 0 Then
Debug.Print “グローバルメモリのアンロックに失敗しました。エラーコード: ” & GetLastError()
CloseClipboard
Exit Function
End If
End If
‘ クリップボードにデータを設定
‘ hMemが成功時に0以外の値を返すので、PtrSafe環境ではLongPtrにキャストが必要
If VBA7 Then
If SetClipboardData(CF_UNICODETEXT, hMem) = 0 Then
Else
If SetClipboardData(CF_UNICODETEXT, hMem) = 0 Then
End If
Debug.Print “クリップボードデータの設定に失敗しました。エラーコード: ” & GetLastError()
‘ この場合、hMemはクリップボードが所有権を持つため解放不要
Else
CopyTextToClipboardAPI = True
‘ hMemはクリップボードが所有権を持つため、成功時は GlobalFree は不要
End If
‘ クリップボードを閉じる
If CloseClipboard() = 0 Then
Debug.Print “クリップボードを閉じられませんでした。エラーコード: ” & GetLastError()
CopyTextToClipboardAPI = False ‘ クローズ失敗は致命的と見なす
End If
Officeバージョンの互換性: Word VBAは、Office 2003、2007、2010、2013、2016、2019、Microsoft 365と、バージョンによって細かなオブジェクトモデルの変更や挙動の違いがある。特に`PtrSafe`キーワードはOffice 2010以降の64bit環境で必須であり、旧環境向けには条件コンパイルで対応する必要がある。
参照設定: VBAプロジェクトが`Microsoft Word xx.0 Object Library`や`Microsoft Forms 2.0 Object Library`（`DataObjects.DataObject`を使用する場合）を参照していることを確認する。環境によっては参照設定が外れてしまい、実行時エラーとなるケースも存在する。
‘ メインルーチン: 現在選択されている表をHTMLに変換し、クリップボードへコピーする
Public Sub ExportSelectedWordTableAsHtmlToClipboard()
Dim app As Word.Application
Dim doc As Word.Document
Dim sel As Word.Selection
Dim targetTable As Word.Table
Dim htmlOutput As String
Dim success As Boolean
On Error GoTo ErrorHandler
Set app = Word.Application
Set doc = app.ActiveDocument
Set sel = app.Selection
‘ 選択範囲が表であるかチェック
If sel.Information(wdWithInTable) And sel.Tables.Count > 0 Then
‘ 選択範囲内の最初の表を取得
Set targetTable = sel.Tables(1)
If Len(htmlOutput) > 0 Then
‘ HTML文字列をクリップボードへコピー (API利用)
success = CopyTextToClipboardAPI(htmlOutput)
If success Then
MsgBox “選択されたWord表をHTML形式でクリップボードにコピーしました。”, vbInformation
Else
MsgBox “クリップボードへのコピーに失敗しました。”, vbCritical
End If
Else
MsgBox “HTML変換に失敗したか、空のデータが生成されました。”, vbExclamation
End If
Else
MsgBox “表が選択されていません。表内の任意のセルを選択してから実行してください。”, vbExclamation
End If
ExitRoutine:
‘ オブジェクトの明示的な解放
Set targetTable = Nothing
Set sel = Nothing
Set doc = Nothing
Set app = Nothing
Exit Sub
ErrorHandler:
MsgBox “処理中にエラーが発生しました: ” & Err.Description & vbCrLf & “エラーコード: ” & Err.Number, vbCritical
Resume ExitRoutine
End Sub
