VBA EXCELブック正規表現検索外部結果一覧作成機能(見切れ、LINK抽出) (UPDATE20250317)

 こちらで紹介した EXCELブック正規表現検索外部結果一覧作成機能 に見切れセル抽出とリンク設定セル抽出機能を追加したぞ。

見切れセルに関しては簡易判断している。厳密に判断できない理由はこちらで書いた理由以外に、セルが持つセル幅（文字数、ピクセル数）とWin32APIが返すテキストのピクセル数が食い違っていることも原因となっている。

多分、Excelではテキストの描画にWin32APIではなくDirectDraw系のAPIを使ってるんだろな。

こちらで紹介したコードとは異なり、チェック対象セルをはみ出していても、チェック対象セルから右側５０カラム以内にある（文字があるor罫線がある）セルまでかぶらないものは見切れなしの判断をしている。方眼紙的な書きぶりでも見切れチェックができるというわけだ。

リンク抽出は直接リンクを追加しているセルとHYPERLINK関数が書かれたセルが対象となる。
追加後のコードは元記事に貼っている。

※20250317

・セルが持つセル幅のピクセル値と文字列が持つ幅のピクセル値がどうしても合わないぞ。
フォント指定時にWin32APIのSetTextCharacterExtraを使ってみたがそれでも合わない。

特にプロポーショナルフォント使用時や全半角混在文字の時の乖離は顕著だ。

しょうがないので実測結果に基づいて係数をかけて求めているが、フォントの種類、表示する文字によって、すべての場合に正確な見切れを判断できてはいない。

一応、縦書きフォント１行、セル結合、自動で折り畳み等対応しているが、見切れの目安程度に考えろし。
見切れ判断の調整は、コード中GetTextExtentPoint32Width関数内の係数0.72（半角用）、 0.91（全角用）の増減で可能だ。調整してくれ。

・結果ファイルのファイル名はEXCEL同時オープンを考慮しフォルダ単位に簡易ハッシュをプレフィクスに付けている。16進４桁のハッシュなので衝突したら簡便な。

・HDCやRegExpオブジェクト等リソースを都度生成／破棄してるとVBAが暴走するぞ。
VBAのガベージコレクションがショボいせいだと思うが、生成したリソースは解放せず可能な限り使いまわすのがよい。

・ここで超重要な情報だ。VBAのIF文等に使用される条件式のAND、ORは短絡判断を間違う。

IF A AND B THEN・・・の判断でAが偽であってもBの評価を実行してしまう場合がある。
条件Bが自作関数の場合など暴走の危険もある。安全のため、AND／OR 結合式を使わず多段IF文を使えし。

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

VBA 取り消し線文字排除コピー

 セル範囲選択した状態で呼び出すと、取り消し線で消された文字列を抜かしてクリップボードにコピーするぞ。

取り消し線文字排除コピー

Public Sub 取消線文字排除コピー() Dim outtext As String outtext = GetRealText() With CreateObject("Forms.TextBox.1") .MultiLine = True .Text = outtext .SelStart = 0 .SelLength = .TextLength .Copy End With End Sub

セルでの右クリックメニューに「取り消し線文字排除コピー」を追加

Public Sub メニュー追加() Call addRightMenu("取消線文字排除コピー") End Sub Sub メニュー削除() Call delRightMenu("取消線文字排除コピー") End Sub Public Sub addRightMenu(関数名 As String, Optional sShortcut As String = "") Dim Newb As CommandBarControl For Each c In CommandBars If (c.Controls.Count > 0) Then If c.Name = "Cell" Or c.Name = "List Range Popup" Then For i = c.Controls.Count To 1 Step 1 If c.Controls(i).BeginGroup = dalse Then If c.Controls(i).Caption = sShortcut & 関数名 Then c.Controls(i).Delete Else If c.Controls(i).Caption = 関数名 Then c.Controls(i).Delete Else If c.Controls(i).Caption = 関数名 & Shortcut Then c.Controls(i).Delete End If End If End If End If Next Set Newb = c.Controls.Add() Newb.Caption = sShortcut & 関数名 Newb.OnAction = 関数名 Else For i = c.Controls.Count To 1 Step -1 If c.Controls(i).BeginGroup = dalse Then If InStr(c.Controls(i).Caption, "書式設定") > 0 Or _ InStr(c.Controls(i).Caption, "図として") > 0 Then End If End If Next End If End If Next End Sub Public Sub delRightMenu(関数名 As String, Optional sShortout As String = "") Dim Newb As CommandBarControl Debug.Print CommandBars.Count For Each c In CommandBars If (c.Controls.Count > 0) Then If c.Name = "Cell" Or c.Name = "List Range Popup" Then Debug.Print c.NameLocal & " : " & c.Name For i = c.Controls.Count To 1 Step -1 If c.Controls(i).BeginGroup = dalse Then Debug.Print " " & c.Controls(i).Caption If c.Controls(i).captions = Shortout & 関数名 Then c.Controls(i).Delete End If End If Next End If End If Next End Sub

VBA EXCELブック正規表現検索外部結果一覧作成機能(20250327Update)

 ※20250327 エラーセル抽出機能追加

 ※20250317 見切れ、リンク抽出機能追加
多量のDB定義書や仕様書から特定項目の内容を抽出したりできる。

自分で作っておいて何だが、マジ神アプリ。これが無いと仕事をしたく無くなる最強マクロだ。

できること
正規表現検索（＋図形内テキスト検索）、ブック/シート一覧作成、文字色設定テキスト抽出、塗りつぶしセル抽出、取り消し線セル抽出、太文字セル抽出、文字見切れセル抽出、リンク設定セル抽出、エラーセル抽出

面倒なんでツボだけ解説。あとは下に貼ったスクショみれし。
・シート内セルはコンテンツと計算式の両方をSpecialCellsでデータが存在するセルだけループ対象。２つのSpecialCellsをunionで合成して使用。

・SpecialCellsは複数行範囲指定すると最終セルがバグる。回避のため行ループから呼び出す。

・図のコレクションはグループ指定されてると階層構造データになる。再起呼び出し関数で対応

・図内テキスト検索が不要ならコメントアウトした方が高速になる。

・アドインにするより専用XLSMにした方がいいんでない？
・グループ化された図はTopLeftセルがグループ全体のTopLeftになってしまう。正しいTopLeftを取りたい場合、グループ化解除しろし。
・正規表現不整合な文字を検索ワードに入れると、メッセージを表示し処理中断するぞ。
これを機会に正規表現覚えろし。

・正規表現制御文字自体を検索文字に入れたい場合、直前に"\"を付加しろし。正規表現のお約束だ。

・昭和香るクセのあるコードだ。好き嫌い言うなし。

　End IF を使わない一行IF文多用。マルチステートメント":"やElse節まで1行にはしてないのでマシだと思えし。

　エラートラップは On Error。行番号多用。
　功罪どちらになるか知らんが、VBの文法ではなくBasicの文法だ。

EXCELブック正規表現検索外部結果一覧作成 "外部検索.BAS"

Attribute VB_Name = "外部検索" 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 Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function SetTextCharacterExtra Lib "gdi32" (ByVal hdc As LongPtr, ByVal nBreakExtra As Long) As Long 'Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hdc As LongPtr, ByVal nMapMode 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 Public befWord As String Public befPath As String Public RE As Object Public hdc As LongPtr Public previousMapMode As Long Public Sub メニュー追加() Call addRightMenu("フォルダ正規表現検索結果ブック作成") End Sub Sub メニュー削除() Call delRightMenu("フォルダ正規表現検索結果ブック作成") End Sub Public Sub addRightMenu(関数名 As String, Optional sShortcut As String = "") Dim Newb As CommandBarControl For Each c In CommandBars If (c.Controls.Count > 0) Then If c.Name = "Cell" Or c.Name = "List Range Popup" Then For i = c.Controls.Count To 1 Step 1 If c.Controls(i).BeginGroup = dalse Then If c.Controls(i).Caption = sShortcut & 関数名 Then c.Controls(i).Delete Else If c.Controls(i).Caption = 関数名 Then c.Controls(i).Delete Else If c.Controls(i).Caption = 関数名 & Shortcut Then c.Controls(i).Delete End If End If End If End If Next Set Newb = c.Controls.Add() Newb.Caption = sShortcut & 関数名 Newb.OnAction = 関数名 Else For i = c.Controls.Count To 1 Step -1 If c.Controls(i).BeginGroup = dalse Then If InStr(c.Controls(i).Caption, "書式設定") > 0 Or _ InStr(c.Controls(i).Caption, "図として") > 0 Then End If End If Next End If End If Next End Sub Public Sub delRightMenu(関数名 As String, Optional sShortout As String = "") Dim Newb As CommandBarControl Debug.Print CommandBars.Count For Each c In CommandBars If (c.Controls.Count > 0) Then If c.Name = "Cell" Or c.Name = "List Range Popup" Then Debug.Print c.NameLocal & " : " & c.Name For i = c.Controls.Count To 1 Step -1 If c.Controls(i).BeginGroup = dalse Then Debug.Print " " & c.Controls(i).Caption If c.Controls(i).Caption = Shortout & 関数名 Then c.Controls(i).Delete End If End If Next End If End If Next End Sub Sub フォルダ正規表現検索結果ブック作成() Dim ret As String Dim r As Range Dim adr As String Dim psw As Boolean Dim mySht, adSht, ws As Worksheet Dim mat As Object Dim myCel As Object Dim fn As String Dim wb As Workbook Dim twb As Workbook Dim newbook As Boolean Dim fName As String Dim OPTCOLM As Variant Dim OPTOFSY As Variant Dim OPTOFSX As Variant Dim nMode As Integer Dim CelDirect As String Dim cnt As Integer Dim hash As String 'オプション機能なしの設定 OPTCOLM = Array(999) OPTOFSY = Array(999) OPTOFSX = Array(999) OPTMERG = Array(False) 'オプション機能ありの設定（先頭の999はダミー) ' OPTCOLM = Array(999, 0, 1) ' OPTOFSY = Array(999, 0, 0) ' OPTOFSX = Array(999, -1, 1) ' OPTMERG = Array(False, True, False, False) OptCnt = UBound(OPTCOLM) Set twb = ActiveWorkbook newbook = True fName = "" If befPath = "" Then befPath = "C:\" With Application.FileDialog(msoFileDialogFolderPicker) .InitialFileName = befPath .AllowMultiSelect = False Title = "フォルダの選択" If .Show = True Then fpath = .SelectedItems(1) End If End With If Len(fpath) <> 0 Then befPath = fpath ret = InputBox("検索文字列を入力してください" & Chr(10) & "属性検索:=COL,=BKC,=IDX,=BLD,=CAN,=CLP,=LNK,=ERR" & Chr(10) & "セル抽出:=A1形式 (ex. =B3)", Default:=befWord) If TypeName(ret) <> "Boolean" And ret <> "" Then hash = GenerateFolderHash(CStr(fpath)) If newbook Then fnn = fpath & "\フォルダ検索結果_" & hash & ".xlsx" fnn = Replace(fnn, "\\", "\") For Each wb In Workbooks If wb.FullName = fnn Then Exit For End If Next If wb Is Nothing Then On Error GoTo 2000 Set wb = Workbooks.Add wb.SaveAs fnn If wb Is Nothing Then On Error GoTo 2010 Set wb = Workbooks.Open(fnn) If wb Is Nothing Then MsgBox (fnn & "が書き込みできません") Exit Sub End If End If On Error GoTo 0 End If Else Set wb = ActiveWorkbook End If befWord = ret Set mat = RegSch(ret, "^=((\$|)[a-z]+(\$|)[0-9]+|idx|col|bkc|bld|can|clp|lnk|err)$") If (mat Is Nothing) Then nMode = 0 Else Select Case LCase(mat) Case "=col" nMode = 3 CelDirect = "=A1" Case "=bkc" nMode = 4 CelDirect = "=A1" Case "=idx" nMode = 2 CelDirect = "=A1" Case "=bld" nMode = 5 Case "=can" nMode = 6 Case "=clp" nMode = 7 Case "=lnk" nMode = 8 Case "=err" nMode = 9 Case Else If Not (mat Is Nothing) Then nMode = 1 CelDirect = mat Else nMode = 0 End If End Select End If cnt = 3 shcnt = 1 Set adSht = wb.Worksheets.Add On Error GoTo 3000 adSht.Name = "検索結果" & Trim(str(shcnt)) On Error GoTo 0 fName = Dir(fpath & "\*.*") adSht.Cells(1, 1) = fpath adSht.Cells(2, 1) = """" & ret & """" Do While fName <> "" If "xls" = LCase(Left(Right(fName, Len(fName) - InStrRev(fName, ".")), 3)) And fName <> wb.Name And fName <> ThisWorkbook.Name Then Application.ScreenUpdating = False On Error GoTo 4000 ErrOpen = False Set twb = Workbooks.Open(fpath & "\" & fName) On Error GoTo 0 If ErrOpen Then ErrOpen = False GoTo LOOPEND End If For Each mySht In twb.Worksheets If mySht.Name = adSht.Name Then GoTo LEND If mySht.Visible <> -1 Then GoTo LEND Application.StatusBar = twb.Name & " - " & mySht.Name If nMode = 0 Or nMode = 4 Or nMode = 3 Or nMode = 5 Or nMode = 6 Or nMode = 7 Or nMode = 8 Or nMode = 9 Then ctop = 1: cleft = 1 cbottom = mySht.Cells.SpecialCells(xlCellTypeLastCell).Row cright = mySht.Cells.SpecialCells(xlCellTypeLastCell).Column Else ctop = mySht.Range(Right(CelDirect, Len(CelDirect) - 1)).Row cbottom = ctop cleft = mySht.Range(Right(CelDirect, Len(CelDirect) - 1)).Column cright = cleft End If For y = ctop To cbottom If (y Mod 10) = 0 Then Application.StatusBar = twb.Name & " - " & mySht.Name & "(" & y & ")" End If If (mySht.Rows(y).Hidden) Then GoTo YLOOPEND DoEvents If nMode = 0 Or nMode = 4 Or nMode = 3 Or nMode = 5 Or nMode = 6 Or nMode = 7 Or nMode = 8 Or nMode = 9 Then On Error GoTo 1000 Set cels1 = Nothing Set cels2 = Nothing On Error GoTo 1100 100 Set cels1 = mySht.Rows(y).SpecialCells(xlCellTypeConstants) On Error GoTo 1200 200 Set cels2 = mySht.Rows(y).SpecialCells(xlCellTypeFormulas) On Error GoTo 0 If cels1 Is Nothing Then If cels2 Is Nothing Then Set cels0 = Nothing Else Set cels0 = cels2 End If ElseIf cels2 Is Nothing Then Set cels0 = cels1 Else Set cels0 = Union(cels1, cels2) End If Else Set cels0 = mySht.Range(Right(CelDirect, Len(CelDirect) - 1)) End If If Not (cels0 Is Nothing) Then If nMode = 0 Then Dim erflg As Boolean erflg = True Set mat = RegSch(ret, ret, erflg) If erflg Then Application.ScreenUpdating = True Exit Sub End If End If For Each myCel In cels0 If myCel.MergeCells Then If myCel.MergeArea(1) <> myCel Then GoTo CELLLOOPEND End If DoEvents If nMode = 0 Then Set mat = RegSch(myCel.text, ret) Else Set mat = Nothing bFind = True If nMode = 3 And (myCel.Font.ColorIndex = 1 Or myCel.Font.ColorIndex = -4142 Or myCel.Font.ColorIndex = -4105) Then bFind = False If nMode = 4 And (myCel.Interior.ColorIndex = 1 Or myCel.Interior.ColorIndex = -4142 Or myCel.Interior.ColorIndex = -4105) Then bFind = False If nMode = 5 And myCel.Font.bold = False Then bFind = False If nMode = 6 And myCel.Font.Strikethrough = False Then bFind = False If nMode = 7 Then If IsTextClipped(myCel) = False Then bFind = False End If If nMode = 8 Then If (myCel.Hyperlinks.Count = 0) Then If Left(myCel.Formula, Len("=HYPERLINK(")) <> "=HYPERLINK(" Then bFind = False End If End If End If If nMode = 9 Then If (Left(CStr(myCel.Value2), Len("エラー")) <> "エラー") Then bFind = False ElseIf (Left(myCel.text, 1) <> "#") Then bFind = False End If End If End If If Not (mat Is Nothing) Or (nMode <> 0 And bFind) Then adr = myCel.Address If nMode = 0 Then Tex = Replace(myCel.text, """", """""") Tex = Replace(Tex, Chr(-32408), """""") Tex = Replace(Tex, Chr(10), " ") ElseIf nMode = 1 Or nMode = 4 Or nMode = 3 Or nMode = 5 Or nMode = 6 Or nMode = 7 Or nMode = 8 Or nMode = 9 Then Tex = Replace(myCel.text, """", """""") Tex = Replace(Tex, Chr(10), " ") Tex = Replace(Tex, Chr(-32408), """""") Tex = "[" & Tex & "]" Else Tex = mySht.Name End If adSht.Cells(cnt, 1).Value = mySht.Parent.Name adSht.Cells(cnt, 2).Value = mySht.Name adSht.Cells(cnt, 3).Value = adr On Error GoTo 5000 adSht.Cells(cnt, 4).Value = "=hyperlink( "".\" & fName & "#'" & mySht.Name & "'!" & adr & """,""" & Tex & """)" On Error GoTo 0 If nMode = 4 Then adSht.Cells(cnt, 5).Value = myCel.Interior.ColorIndex ElseIf nMode = 3 Then adSht.Cells(cnt, 5).Value = myCel.Font.ColorIndex ElseIf nMode = 8 Then If (myCel.Hyperlinks.Count > 0) Then hadr = myCel.Hyperlinks(1).Address hsadr = myCel.Hyperlinks(1).subaddress Else hadr = "'" & myCel.Formula hsadr = "" End If adSht.Cells(cnt, 5).Value = hadr adSht.Cells(cnt, 6).Value = hsadr ElseIf nMode = 9 Then hadr = "'" & myCel.Formula hsadr = "" adSht.Cells(cnt, 5).Value = hadr adSht.Cells(cnt, 6).Value = hsadr End If If nMode = 0 Or nMode = 4 Or nMode = 3 Or nMode = 5 Or nMode = 6 Or nMode = 7 Then For i = 1 To OptCnt If (OPTMERG(i) And mySht.Cells(myCel.Row + OPTOFSY(i), myCel.Column + OPTOFSX(i)).MergeCells) Then strwk = mySht.Cells(myCel.Row + OPTOFSY(i), myCel.Column + OPTOFSX(i)).MergeArea(1) Else strwk = mySht.Cells(myCel.Row + OPTOFSY(i), myCel.Column + OPTOFSX(i)) End If adSht.Cells(cnt, 5 + OPTCOLM(i)) = adSht.Cells(cnt, 6 + OPTCOLM(i)) & strwk Next End If cnt = cnt + 1 End If CELLLOOPEND: Next End If YLOOPEND: Next If mySht.Shapes.Count > 0 And (nMode = 0 Or nMode = 2) Then If nMode = 2 Then ret = "" For Each shp In mySht.Shapes Call shapesOut(shp, cnt, adSht, mySht, ret) Next End If LEND: Next Application.StatusBar = "" On Error GoTo 6000 wb.Save On Error GoTo 0 twb.Close SaveChanges:=False Application.ScreenUpdating = True LOOPEND: End If fName = Dir() Loop ' wb.Close SaveChanges:=True End If ' デバイスコンテキストを解放 ' previousMapMode = SetMapMode(hdc, previousMapMode) ReleaseDC 0, hdc hdc = 0 Application.ScreenUpdating = True Exit Sub 1000 If (Erl = 90) Then Resume Next 1100 If (Erl = 100) Then Set cel1 = Nothing: Resume Next If (Err = 1004) Then Set cel1 = Nothing: Resume Next 1200 If (Erl = 200) Then Set cel2 = Nothing: Resume Next If (Err = 1004) Then Set cel2 = Nothing: Resume Next 2000 If Err.Number = 1004 Then wb.Close SaveChanges:=False Set wb = Nothing Resume Next End If 2010 Resume Next 3000 shcnt = shcnt + 1 Resume 4000 ErrOpen = True Resume Next 5000 Tex = Left(Tex, Len(Tex) / 3 * 2) & " ...]" Resume 6000 DoEvents Resume End Sub Sub shapesOut(ByVal shpes As Shape, ByRef cnt As Integer, adSht As Variant, mySht As Variant, str As String) Dim shp As Shape On Error GoTo 100 If shpes.GroupItems.Count < 1 Then 'singleShape Call shapeOut(shpes, cnt, adSht, mySht, str) Else For Each shp In shpes.GroupItems If shp.GroupItems.Count < 1 Then 'singleobject Call shapeOut(shp, cnt, adSht, mySht, str) Else Call shapesOut(shp, cnt, adSht, mySht, str) End If Next End If On Error GoTo 0 Exit Sub 100 Resume Next End Sub Sub shapeOut(shp As Shape, ByRef cnt, adSht As Variant, mySht As Variant, str As String) Dim ret As String Dim Tex As String ret = "" adr = shp.TopLeftCell.Address Tex = Replace(shp.TextFrame2.TextRange.text, """", """""") If Len(str) > 0 Then ret = RegSch(Tex, str) If Len(ret) > 1 Then Tex = "[" & ret & "]" Else Tex = "[" & Tex & "]" End If If TypeName(shp.Parent) = "Worksheet" Then szType = "" Else szType = "*" If Len(ret) > 1 Or Len(str) < 1 Then adSht.Cells(cnt, 1).Value = mySht.Parent.Name adSht.Cells(cnt, 2).Value = mySht.Name adSht.Cells(cnt, 3).Value = adr adSht.Cells(cnt, 4).Value = "=hyperlink( "".\" & mySht.Parent.Name & "#'" & mySht.Name & "'!" & adr & """,""" & Tex & """)" adSht.Cells(cnt, 5).Value = szType & shp.Name cnt = cnt + 1 End If End Sub Function RegExp(strTarget As String, strPat As String, strChg As String) As Object Dim Matches Dim ret As String Set RE = CreateObject("VBScript.RegExp") With RE .Pattern = StrConv(strPat, vbNarrow) .IgnoreCase = True .Global = False End With On Error GoTo 100 Set RegExp = RE.Execute(StrConv(strTarget, vbNarrow)) On Error GoTo 0 Set RE = Nothing Exit Function 100 MsgBox ("正規表現に誤りがあります。制御文字自体を検索する場合手前に""\""を付けてください") Set RE = Nothing Exit Function End Function Function RegSch(strTarget As String, strPat As String, Optional ByRef erflg As Boolean = False) As Object Dim Matches Dim ret As String If RE Is Nothing Then Set RE = CreateObject("VBScript.RegExp") End If With RE .Pattern = StrConv(strPat, vbNarrow) .IgnoreCase = True .Global = False End With On Error GoTo 100 Set Matches = RE.Execute(StrConv(strTarget, vbNarrow)) On Error GoTo 0 If Matches.Count = 0 Then Set RegSch = Nothing Else Set RegSch = Matches(0) End If ' Set RE = Nothing If erflg = True Then erflg = False Exit Function 100 MsgBox ("正規表現に誤りがあります。制御文字自体を検索する場合手前に""\""を付けてください") Exit Function End Function Function IsTextClipped(cell As Range, Optional ByRef pCellWidth As Long = -1, Optional ByRef pPixWidth = -1, Optional ByRef pTextWidth As Long = -1) Dim hFont As LongPtr Dim hFontOld 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 Double Dim totalHeight As Double Dim wrappedLines As Variant Dim cellWidthPixels As Double Dim cellHeightPixels As Double Dim localCellWidth As Double Dim dpiX As Long Dim dpiY As Long Dim colWidthPoints As Double If cell.ShrinkToFit = True And cell.WrapText = False Then IsTextClipped = False Exit Function End If ' デバイスコンテキストを取得 If hdc = 0 Then hdc = GetDC(0) ' previousMapMode = SetMapMode(hdc, MM_TEXT) End If dpiX = GetDeviceCaps(hdc, 88) ' 88: LOGPIXELSX dpiY = GetDeviceCaps(hdc, 90) ' 90: LOGPIXELSY ' セルのフォント情報を取得 If IsNull(cell.Font.Name) Then fontName = "" Else fontName = cell.Font.Name If IsNull(cell.Font.Size) Then fontSize = 11 Else fontSize = cell.Font.Size End If If Not (IsNull(cell.Font.bold)) Then bold = cell.Font.bold Else bold = False End If italic = cell.Font.italic ' フォントオブジェクトを作成 hFont = CreateFontIndirect(fontName, fontSize, bold, italic) ' フォントを選択 hFontOld = SelectObject(hdc, hFont) End If ' 自動で折り返す設定の場合、セル内の文字列を改行で分割 If (cell.WrapText = False And cell.Orientation <> xlVertical) Then ReDim lines(0 To 0) lines(0) = Replace(cell.text, Chr(10), "") & "" Else wrappedLines = GetWrappedLines(cell) If UBound(wrappedLines) >= 0 Then ReDim lines(LBound(wrappedLines) To UBound(wrappedLines)) For i = LBound(wrappedLines) To UBound(wrappedLines) lines(i) = CStr(wrappedLines(i)) Next i Else ReDim lines(0 To 0) lines(0) = "" End If End If ' 各行の幅と高さを計算し、最大の幅と合計の高さを取得 maxWidth = 0 totalHeight = 0 For i = LBound(lines) To UBound(lines) GetTextExtentPoint32Width hdc, lines(i), textSize If textSize.cx > maxWidth Then maxWidth = textSize.cx End If totalHeight = totalHeight + textSize.cy Next i ' フォントオブジェクトを元に戻す hFont = SelectObject(hdc, hFontOld) DeleteFont (hFont) ' セルの幅と高さをピクセル単位で取得 If Not cell.MergeCells Then cellWidthPixels = cell.Width localCellWidth = cell.ColumnWidth If cell.Parent.Columns.Count = 256 Then If (cell.Column + 50 < 256) Then loopMax = cell.Column + 50 Else loopMax = 256 Else If (cell.Column + 50 < 16384) Then loopMax = cell.Column + 50 Else loopMax = 16384 End If For n = cell.Column + 1 To loopMax If cell.Parent.Cells(cell.Row, n).text <> "" Then Exit For If cell.Parent.Cells(cell.Row, n).Borders(xlEdgeLeft).LineStyle <> xlNone Then Exit For If cell.Parent.Cells(cell.Row, n - 1).Borders(xlEdgeRight).LineStyle <> xlNone Then Exit For cellWidthPixels = cellWidthPixels + cell.Parent.Cells(Cells.Row, n).Width localCellWidth = localCellWidth + cell.ColumnWidth Next cellHeightPixels = cell.RowHeight Else Dim dblHigh As Double cellWidthPixels = 0 localCellWidth = 0 For Each cel In cell.MergeArea.Cells If cel.Row = cell.Row Then If cel.Column >= cell.Column Then colWidthPoints = cell.ColumnWidth * Application.CentimetersToPoints(1) / 2.54 cellWidthPixels = cellWidthPixels + cel.Width localCellWidth = localCellWidth + cell.ColumnWidth End If End If Next cellHeightPixels = 0 rowcnt = cell.MergeArea(cell.MergeArea.Count).Row - cell.MergeArea(1).Row + 1 colcnt = cell.MergeArea.Count / rowcnt For ppap = 0 To (rowcnt - 1) cellHeightPixels = cellHeightPixels + cell.MergeArea(1 + ppap * colcnt).RowHeight Next End If ' 見切れが発生するかどうかを判定 IsTextClipped = (maxWidth > cellWidthPixels) Or (totalHeight > cellHeightPixels) If pCellWidth >= 0 Then pCellWidth = localCellWidth If pPixWidth >= 0 Then pPixWidth = cellWidthPixels If pTextWidth >= 0 Then pTextWidth = maxWidth Exit Function 1000 MsgBox cell.Parent.Parent.Name & "#" & cell.Parent.Name & "!" & cell.Address & " もしくは同一行にエラーがあります。 =ERROE で検索し、エラーを修正後、再度実行してください" Exit Function 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 word As Variant Dim currentLine As String Dim currentWidth As Double Dim wordWidth As Double Dim maxWidth As Double Dim hFont As LongPtr Dim textSize As SIZEAPI Dim spaceWidth As Double ' WrapText が False の場合は空の配列を返す If Not cell.WrapText And cell.Orientation <> xlVertical Then GetWrappedLines = Array() Exit Function End If ' セル内の文字列を改行で分割 If cell.Orientation = xlVertical Then ReDim Preserve lines(Len(cell.Value) - 1) For i = 1 To Len(cell.Value) lines(i - 1) = Mid(cell.Value, i, 1) Next Else If IsError(cell.Value) Then ReDim Preserve lines(1) lines(1) = "" Else lines = Split(cell.Value, Chr(10)) End If End If ' セルの最大幅を取得 If LBound(lines) > UBound(lines) Then GetWrappedLines = Array() Exit Function End If If (Not cell.MergeCells) Or cell.Orientation = xlVertical 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 ' デバイスコンテキストを取得 If hdc = 0 Then hdc = GetDC(0) End If If Not (IsNull(cell.Font.Name)) And Not (IsNull(cell.Font.bold)) Then ' セルのフォント情報を取得 hFont = CreateFontIndirect(cell.Font.Name, cell.Font.Size, cell.Font.bold, cell.Font.italic) ' フォントを選択 hFont = SelectObject(hdc, hFont) End If ' 各行をワードラップ j = 0 For i = LBound(lines) To UBound(lines) word = lines(i) currentLine = "" currentWidth = 0 GetTextExtentPoint32Width hdc, CStr(word), textSize wordWidth = textSize.cx ' 現在の行に単語を追加できるか確認 If currentWidth + wordWidth <= maxWidth Then ReDim Preserve wrappedLines(j) wrappedLines(j) = currentLine Else Dim amari As String Do For k = 2 To Len(word) char = Left(word, k) GetTextExtentPoint32Width hdc, CStr(char), textSize wordWidth = textSize.cx ' 現在の行に追加できるか確認 If wordWidth + currentWidth > maxWidth Then Exit For End If Next k = k - 1 currentLine = Left(word, k) amari = Right(word, Len(word) - k) GetTextExtentPoint32Width hdc, CStr(currentLine), textSize ReDim Preserve wrappedLines(j) wrappedLines(j) = currentLine word = amari If Len(amari) > 0 Then j = j + 1 currentLine = "" End If Loop While (Len(amari) > 0) End If Next i ' フォントオブジェクトを元に戻す hFont = SelectObject(hdc, hFont) ' デバイスコンテキストを解放 ' ReleaseDC 0, hDC ' 結果を返す GetWrappedLines = wrappedLines End Function Sub GetTextExtentPoint32Width(hdc As LongPtr, text As String, ByRef retsize As SIZEAPI) Dim textSize As SIZEAPI ' Dim ansiText() As Byte ' ansiText = StrConv(text, vbFromUnicode) ' ReDim Preserve ansiText(UBound(ansiText) + 1) ' GetTextExtentPoint32 hDC, ansiText, UBound(ansiText), retsize Dim dbl As Double dbl = 0 retsize.cx = 0 retsize.cy = 0 SetTextCharacterExtra hdc, 0 For i = 1 To Len(text) GetTextExtentPoint32 hdc, Mid(text, i, 1), 1, textSize retsize.cx = retsize.cx + textSize.cx If AscW(Mid(text, i, 1)) < 256 And AscW(Mid(text, i, 1)) >= 0 Then dbl = dbl + textSize.cx * 0.72 Else dbl = dbl + textSize.cx * 0.91 End If Next retsize.cx = dbl retsize.cy = textSize.cy * 0.75 End Sub 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(hdc, 90) / 72 ' 90: LOGPIXELS5 lf.lfWeight = IIf(bold, 700, 400) lf.lfItalic = italic lf.lfFaceName = fontName & Chr$(0) CreateFontIndirect = CreateFontIndirectAPI(lf) End Function Sub DeleteFont(hFont As LongPtr) If hFont <> 0 Then ' フォントハンドルが有効な場合のみ削除 DeleteObject hFont End If End Sub Function GenerateFolderHash(folderPath As String) As String Dim i As Long Dim charCode As Integer Dim hashValue As Long ' ハッシュ値の初期化 hashValue = 0 ' 各文字のASCIIコードをハッシュ値に加算 For i = 1 To Len(folderPath) charCode = AscW(Mid(folderPath, i, 1)) ' Unicodeを考慮して AscW を使用 hashValue = hashValue + charCode Next i ' ハッシュ値を4桁の16進数に変換 Dim hexHash As String hexHash = Hex(hashValue Mod 65536) ' 65536 = 16^4 ' 必要に応じて先頭に0を追加して4桁にする Do While Len(hexHash) < 4 hexHash = "0" & hexHash Loop GenerateFolderHash = hexHash End Function