VBA 見切れセル判断関数

パラメタで渡されたセルに見切れが発生しているか判断する関数、TestIsTextClipped()だ。

WindowsAPI バリバリ呼んでるぞ。

VBAのつぼ
50％程度、gemini先生に書かせてみた。
都度、バグを指摘すれば、改善したコードを書いてくれる、、、が、こちらが気が付かないと正しいコードを書いてくれない。

現時点では、自分の能力以上のコードは作ってくれない。

しかし、優秀で仕事の早い後輩程度の助けにはなる。

セル見切れは以下の考慮の元作成したので、判断が正確じゃない場合がある。
・セル内一部の文字だけのフォント・フォントサイズの変更を考慮すると処理が重くなりすぎるので考慮していない

・セルに「縮小して表示」が設定されている場合、高さの見切れは考慮してない。表示上のフォントサイズを取得して、高さの再計算をする必要がある。

・セルに「折り返して表示」が設定されている場合、折り返しの正確なルールを再現できなかったので、高さの見切れに間違う場合がある。英語、日本語の混合ルールは複雑。

・セルの横位置が標準以外の場合、幅見切れを正確に認識できていない。

・セルの横位置が標準の場合、セル標準横余白が不明のため、余白は考慮していない。

・セルが結合されている場合、結合範囲で見切れや折り返しを判断している。

しかし、仕様書等、標準の書式で書かれている文書なら、ほぼ正確に見切れ判断できるだろう。

単体では用途が狭い関数だが、こちらで公開している検索一覧作成機能に追加する予定だ。

Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As LongPtr, ByVal lpString As String, ByVal c As Long, lpSize As SIZEAPI) As Long Private Declare PtrSafe Function CreateFontIndirectAPI Lib "gdi32" Alias "CreateFontIndirectW" (lpLogFont As LOGFONT) As LongPtr Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long Private Type SIZEAPI cx As Long cy As Long End Type Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * 32 End Type Sub TestIsTextClipped() Dim targetCell As Range Dim isClipped As Boolean ' 対象のセルを設定 Set targetCell = Range("A1") ' 見切れが発生するかどうかを取得 isClipped = IsTextClipped(targetCell) ' 結果をイミディエイトウィンドウに出力 Debug.Print "見切れが発生: " & isClipped End Sub Function IsTextClipped(cell As Range) As Boolean Dim hDC As LongPtr Dim hFont As LongPtr Dim textSize As SIZEAPI Dim fontName As String Dim fontSize As Long Dim bold As Boolean Dim italic As Boolean Dim lines() As String Dim i As Long Dim maxWidth As Long Dim totalHeight As Long Dim wrappedLines As Variant Dim cellWidthPixels As Long Dim cellHeightPixels As Long If cell.ShrinkToFit = True And cell.WrapText = False Then IsTextClipped = False Exit Function End If ' デバイスコンテキストを取得 hDC = GetDC(0) ' セルのフォント情報を取得 fontName = cell.Font.Name fontSize = cell.Font.Size bold = cell.Font.bold italic = cell.Font.italic ' フォントオブジェクトを作成 hFont = CreateFontIndirect(fontName, fontSize, bold, italic) ' フォントを選択 hFont = SelectObject(hDC, hFont) ' 自動で折り返す設定の場合、セル内の文字列を改行で分割 If (cell.WrapText = False) Then ReDim lines(0 To 0) lines(0) = Replace(cell.Value, Chr(10), "") & "" Else wrappedLines = GetWrappedLines(cell) ReDim lines(LBound(wrappedLines) To UBound(wrappedLines)) ' Variant型の配列の各要素をString型に変換してString型の配列に格納する For i = LBound(wrappedLines) To UBound(wrappedLines) lines(i) = CStr(wrappedLines(i)) Next i End If ' 各行の幅と高さを計算し、最大の幅と合計の高さを取得 maxWidth = 0 totalHeight = 0 For i = LBound(lines) To UBound(lines) GetTextExtentPoint32 hDC, lines(i), Len(lines(i)), textSize If textSize.cx > maxWidth Then maxWidth = textSize.cx End If totalHeight = totalHeight + textSize.cy Next i ' フォントオブジェクトを元に戻す hFont = SelectObject(hDC, hFont) ' デバイスコンテキストを解放 ReleaseDC 0, hDC ' セルの幅と高さをピクセル単位で取得 If Not cell.MergeCells Then cellWidthPixels = cell.Width Else cellWidthPixels = 0 For Each cel In cell.MergeArea.Cells If cel.Row = cell.Row Then If cel.Column >= cell.Column Then cellWidthPixels = cellWidthPixels + cel.Width End If End If Next End If cellHeightPixels = cell.RowHeight ' 見切れが発生するかどうかを判定 IsTextClipped = (maxWidth > cellWidthPixels) Or (totalHeight > cellHeightPixels) End Function Function GetWrappedLines(cell As Range) As Variant Dim lines() As String Dim wrappedLines() As String Dim i As Long Dim j As Long Dim line As String Dim words() As String Dim currentLine As String Dim currentWidth As Long Dim wordWidth As Long Dim maxWidth As Long Dim hDC As LongPtr Dim hFont As LongPtr Dim textSize As SIZEAPI ' WrapText が False の場合は空の配列を返す If Not cell.WrapText Then GetWrappedLines = Array() Exit Function End If ' セル内の文字列を改行で分割 lines = Split(cell.Value, Chr(10)) ' セルの最大幅を取得 ' maxWidth = (cell.ColumnWidth - 0.4) * 7 ' ColumnWidth は文字数単位なのでピクセル単位に変換 If Not cell.MergeCells Then maxWidth = cell.Width Else maxWidth = 0 For Each cel In cell.MergeArea.Cells If cel.Row = cell.Row Then If cel.Column >= cell.Column Then maxWidth = maxWidth + cel.Width End If End If Next End If ' デバイスコンテキストを取得 hDC = GetDC(0) ' セルのフォント情報を取得 hFont = CreateFontIndirect(cell.Font.Name, cell.Font.Size, cell.Font.bold, cell.Font.italic) ' フォントを選択 hFont = SelectObject(hDC, hFont) ' 各行をワードラップ j = 0 For i = LBound(lines) To UBound(lines) words = Split(lines(i), " ") ' スペースで分割 currentLine = "" currentWidth = 0 For Each word In words ' 単語の幅を取得 GetTextExtentPoint32 hDC, word, Len(word), textSize wordWidth = textSize.cx ' 現在の行に単語を追加できるか確認 If currentWidth + wordWidth <= maxWidth Then If currentLine <> "" Then currentLine = currentLine End If currentLine = currentLine & word currentWidth = currentWidth + wordWidth + GetTextExtentPoint32Width(hDC, " ") ' スペースの幅を追加 Else Dim amari As String Do amari = "" For k = 1 To Len(word) char = Mid(word, k, 1) ' chars = Split(StrConv(word, vbUnicode), Chr(0)) ' 文字単位で分割 ' For Each char In chars GetTextExtentPoint32 hDC, char, 1, textSize wordWidth = textSize.cx GetTextExtentPoint32 hDC, "　", 1, textSize wordWidth2 = textSize.cx ' 現在の行に追加できるか確認 If currentWidth + wordWidth + wordWidth2 * 0.7 <= maxWidth Then currentLine = currentLine & char currentWidth = currentWidth + wordWidth Else amari = amari & char currentWidth = currentWidth + wordWidth End If Next k ReDim Preserve wrappedLines(j) wrappedLines(j) = currentLine j = j + 1 currentLine = "" word = amari GetTextExtentPoint32 hDC, amari, Len(amari), textSize If textSize.cx <= maxWidth Then currentLine = word currentWidth = 0 Loop While (textSize.cx > maxWidth) End If Next word ' 最後の行を配列に追加 ReDim Preserve wrappedLines(j) wrappedLines(j) = currentLine j = j + 1 Next i ' フォントオブジェクトを元に戻す hFont = SelectObject(hDC, hFont) ' デバイスコンテキストを解放 ReleaseDC 0, hDC ' 結果を返す GetWrappedLines = wrappedLines End Function Function GetTextExtentPoint32Width(hDC As LongPtr, text As String) As Long Dim textSize As SIZEAPI GetTextExtentPoint32 hDC, text, Len(text), textSize GetTextExtentPoint32Width = textSize.cx End Function Private Function CreateFontIndirect(fontName As String, fontSize As Long, bold As Boolean, italic As Boolean) As LongPtr Dim lf As LOGFONT lf.lfHeight = -fontSize * GetDeviceCaps(GetDC(0), 90) / 72 ' 90: LOGPIXELSY lf.lfWeight = IIf(bold, 700, 400) lf.lfItalic = italic lf.lfFaceName = fontName & Chr$(0) CreateFontIndirect = CreateFontIndirectAPI(lf) End Function