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