'作成者：mame '作成日：2024/3/20 '概要：画像ファイルを指定したレイアウトで配列し、ファイル名を画像の下に配置するマクロです。 '更新日：2024/7/17 '更新内容：漢字にルビを振る機能を追加しました。 Sub InsertImagesInColumns() '画像を配列し、ファイル名を挿入するメインプログラム Dim doc As Document Dim header As HeaderFooter Dim frmData As Object Dim numRows As Integer Dim numColumns As Integer ' Dim printableWidth As double Dim printableHeight As Double Dim tbl As Table Dim lastRow As row Dim lastRowIndex As Integer Dim lastColumnIndex As Integer Dim startRowIndex As Integer Dim startColumnIndex As Integer Dim cl As Cell Dim img As inlineShape Dim shp As Shape Dim row As Integer Dim col As Integer Dim lastCell As Cell Dim cellText As String Dim dlg As FileDialog Dim sltItem As Variant Dim sltItemName As String Dim sltItemIndex As Integer Dim imgWidth As Double Dim imgHeight As Double Dim inlineShape As inlineShape Dim regEx As Object Dim fontSize As Integer Dim fontColor As Double Dim paraRange As Range Dim paraStart As Long ' 現在のドキュメントを取得します。 Set doc = ActiveDocument ' 変数の初期化 startRowIndex = 1 ' 画像を挿入する最初の行 startColumnIndex = 1 ' 画像を挿入する最初の列 sltItemIndex = 0 ' 挿入する画像ファイルの番号 fontColor = wdBlack ' フォントを黒色に '既にテーブルが作成されているかを判定します。なければ新規作成します。 If Not doc.Tables.Count > 0 Then '指定したレイアウトのテーブルを作成します。 'フォームの内容(ディクショナリ)を読み込みます。 Set frmData = FormDataDic() ' ページの向きを設定します。 doc.PageSetup.Orientation = frmData("direction") ' テーブルの行数と列数を設定します。 numRows = frmData("row") numColumns = frmData("column") ' 余白と印刷範囲を設定します。 With doc.PageSetup .LeftMargin = MillimetersToPoints(5) ' 左余白を5mmに設定 .RightMargin = MillimetersToPoints(5) ' 右余白を5mmに設定 .TopMargin = MillimetersToPoints(5) ' 上余白を5mmに設定 .BottomMargin = MillimetersToPoints(5) ' 下余白を5mmに設定 .HeaderDistance = MillimetersToPoints(0) 'ヘッダーの開始位置 .FooterDistance = MillimetersToPoints(0) 'フッターの開始位置 ' 印刷範囲を計算します。 ' printableWidth = .PageWidth - (.LeftMargin + .RightMargin) printableHeight = .PageHeight - (.TopMargin + .BottomMargin) End With 'ヘッダーにレイアウト情報を設定します Set header = doc.Sections(1).Headers(wdHeaderFooterPrimary) header.Range.Text = numRows & "行" & numColumns & "列" header.Range.Font.ColorIndex = wdWhite header.Range.Font.Size = 5 ' 指定された行列に従ってテーブルを作成します。 doc.Tables.Add Range:=doc.Range(0, 0), numRows:=1, numColumns:=numColumns Set tbl = doc.Tables(1) tbl.AllowAutoFit = False ' 自動調整を無効化 tbl.Borders.OutsideLineStyle = wdLineStyleSingle ' 外枠の表示 tbl.Borders.InsideLineStyle = wdLineStyleSingle ' 内枠の表示 tbl.Rows.HeightRule = wdRowHeightExactlys 'セルの高さは固定値 tbl.Rows.Height = (printableHeight - MillimetersToPoints(5)) / numRows '改ページしないようにテーブルの下に1行分(5mm)のスペースを作ります 'ファイルに既にテキストが入力されていた場合、挿入したテーブルの下にそのテキストを表示します Set paraRange = tbl.Range 'パラグラフの範囲を取得します paraRange.Collapse direction:=wdCollapseEnd paraStart = paraRange.Start paraRange.Move wdParagraph, 1 paraRange.Start = paraStart If Len(paraRange.Text) > 1 Then '非印字文字が1文字既定で入っています。 paraRange.End = paraStart paraRange.InsertAfter vbCr '改ページして、既存のテキストを表示します End If paraRange.End = paraStart 'テーブルの最後にカーソルを移動します With paraRange.Find 'テーブル直下の最初の改行コードを探して、改ページしないようにフォントサイズを1ポイントにします .Text = vbCr .Forward = True .Execute End With paraRange.Font.Size = 1 '既存のテーブルがあれば、そのテーブルに画像を追加します。 Else Set tbl = doc.Tables.Item(1) tbl.AllowAutoFit = False ' 自動調整を無効化 numColumns = tbl.Columns.Count 'テーブルの列数を取得します ' 最後のセルが空か判定するために正規表現オブジェクトを作成します Set regEx = CreateObject("VBScript.RegExp") With regEx .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "[\x00-\x1F\x7F]+" ' 非印字文字を削除する正規表現パターン End With ' 画像ファイルを追加する最初のセルの位置を特定するために、現時点のデータが入っている最後のセルを取得します ' まずテーブル内の最後の行を取得します。 Set lastRow = tbl.Rows(tbl.Rows.Count) For Each Cell In lastRow.Cells ' データがある最後のセルが何列目かを判定します cellText = regEx.Replace(Cell.Range.Text, "") ' セル内のテキストから非印字文字を削除します。 ' テーブルのデータがある最後のセルの列数を取得します。 If Trim(cellText) = "" Then 'セルが空の場合 lastRowIndex = lastRow.Index 'データがある最後の行 lastColumnIndex = Cell.ColumnIndex - 1 'データがある最後の列 startRowIndex = lastRow.Index '画像を挿入する行 startColumnIndex = Cell.ColumnIndex '画像を挿入する列 Exit For ' 最後のセルを見つけたら終了します ElseIf Cell.ColumnIndex = tbl.Columns.Count Then '最後の行・列数目のセルまでデータがある場合 lastRowIndex = lastRow.Index '最後の行数 lastColumnIndex = Cell.ColumnIndex '最後の列数 startRowIndex = lastRow.Index + 1 '行数を追加 startColumnIndex = 1 '列数は追加された行の1列目 tbl.Rows.Add End If Next Cell End If ' ファイルダイアログを表示して画像ファイルを選択します。 Set dlg = Application.FileDialog(msoFileDialogFilePicker) With dlg .Title = "画像ファイルを選択してください" .Filters.Clear .Filters.Add "画像ファイル", "*.jpg; *.jpeg; *.png; *.gif; *.bmp" .AllowMultiSelect = True ' 複数のファイルを選択可能にします If .Show = -1 Then ' 画像ファイルが選択された場合 ' 画像ファイルを挿入するセルの位置を設定します row = startRowIndex col = startColumnIndex For Each sltItem In .SelectedItems ' 画像を挿入するセルを指定 Set cl = tbl.Cell(row, col) ' 画像をテーブルセルに挿入 Set img = doc.InlineShapes.AddPicture(FileName:=sltItem, Range:=cl.Range) ' ファイル名を取得します sltItemName = Right(sltItem, Len(sltItem) - InStrRev(sltItem, "\")) sltItemName = Left(sltItemName, InStrRev(sltItemName, ".") - 1) ' ファイル名を挿入します cl.Range.Collapse direction:=wdCollapseEnd cl.Range.InsertAfter vbCr & sltItemName ' 位置を設定します cl.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter ' 画像の水平配置をセンターに設定 cl.VerticalAlignment = wdCellAlignVerticalCenter ' 画像の垂直配置をセンターに設定 ' 画像サイズ、フォントサイズを修正します UpdateImagesInColumns cl ' 次のセルに移ります。 sltItemIndex = sltItemIndex + 1 If sltItemIndex < .SelectedItems.Count Then ' 列を切り替え col = col + 1 ' 次の列に移ります If col - numColumns > 0 Then ' 新しい行を追加 tbl.Rows.Add row = row + 1 col = 1 End If End If Next sltItem End If End With End Sub Sub UpdateImagesInColumns(cl As Cell) 'セル内の画像サイズ、フォントサイズを修正・更新するプログラム Dim frmData As Object Dim regEx As Object Dim clMargin As Integer Dim img As inlineShape Dim sltItemName As String Dim charNumPerLine As Integer Dim lineSpace As Double Dim lineNum As Integer Dim fontSize As Integer Dim fontColor As Double Dim rubyFontSize As Double Dim wordRange As Range '文字列のrange Dim charRange As Range '一文字のrange Dim diff As Double 'フォームを読み込みます Set frmData = FormDataDic() '変数の初期化 sltItemName = "" Set wordRange = Nothing Set charRange = Nothing 'セルの高さを固定します cl.SetHeight rowheight:=cl.Height, HeightRule:=wdRowHeightExactly ' セル内に画像があるか確認 If cl.Range.InlineShapes.Count > 0 Then '画像を取得します Set img = cl.Range.InlineShapes(1) ' 画像のサイズを設定 img.LockAspectRatio = msoTrue '縦横比固定 '画像をセルのサイズに合わせます。 If img.Width > cl.Width Then If img.Height > cl.Height Then ' 画像の幅＞セルの幅　かつ　画像の高さ＞セルの高さ If (img.Width - cl.Width) >= (img.Height - cl.Height) Then 'かつ　幅と高さで差が大きい方をセルに合わせて縮小します。 img.Width = cl.Width Else img.Height = cl.Height End If Else img.Width = cl.Width ' 画像の幅＞セルの幅　かつ　画像の高さ＜＝セルの高さ　の場合は画像の幅をセルの幅に縮めます End If Else If img.Height > cl.Height Then ' 画像の幅＜＝セルの幅　かつ　画像の高さ＞セルの高さ　の場合は画像の高さをセルの高さに縮めます img.Height = cl.Height Else ' 画像の幅＜＝セルの幅　かつ　画像の高さ＜＝セルの高さ If (cl.Width - img.Width) <= (cl.Height - img.Height) Then ' かつ　幅と高さで差が小さい方をセルに合わせて拡大します。 img.Width = cl.Width Else img.Height = cl.Height End If End If End If 'セルのマージン分だけ画像を小さくします clMargin = MillimetersToPoints(5) If (cl.Width - img.Width) < clMargin Then '幅を小さくします img.Width = img.Width - (clMargin - (cl.Width - img.Width)) End If If (cl.Height - img.Height) < clMargin Then '高さを小さくします img.Height = img.Height - (clMargin - (cl.Height - img.Height)) End If '文字のフォントサイズを変更するために、まずルビが振られているかを判定します。 If cl.Range.Fields.Count > 0 Then 'ルビがふられている場合、一旦削除します DeleteRuby cl.Range End If ' 正規表現オブジェクトを作成します Set regEx = CreateObject("VBScript.RegExp") With regEx .Global = True .MultiLine = True .IgnoreCase = False .Pattern = "[\x00-\x1F\x7F\/]+" ' 非印字文字を削除する正規表現パターン End With '非印字文字を削除し、テキストを取得します sltItemName = regEx.Replace(cl.Range.Text, "") 'ファイル名を範囲指定します。 Set wordRange = Selection.Range wordRange.SetRange cl.Range.Start, cl.Range.End wordRange.Collapse wdCollapseStart With wordRange.Find .Text = sltItemName .Execute End With 'フォントの設定情報をフォームから読み込みます fontSize = frmData("fontSize") fontColor = frmData("fontColor") rubyFontSize = frmData("rubyFontSize") ' ファイル名が一行に入るようにフォントサイズを設定します charNumPerLine = Int(cl.Width / fontSize) '一行に入る文字数 ' 一行を越える場合、文字サイズを縮小します If Len(sltItemName) >= charNumPerLine Then fontSize = Int(cl.Width / (Len(sltItemName) + 1)) rubyFontSize = Int(rubyFontSize * (fontSize / frmData("fontSize"))) End If ' 行間の大きさを設定します lineSpace = fontSize * 1.1 '+ MillimetersToPoints(2) ' ルビを振る場合、その分の行間もとります。 For Each charRange In wordRange.Characters '単語に漢字が含まれているかを判定します If IsKanji(charRange.Text) = True And Not rubyFontSize = 0 Then lineSpace = lineSpace + (rubyFontSize * 0.7) Exit For End If Next charRange ' 行数を設定します lineNum = 1 ' 画像の大きさを修正します diff = 0 diff = cl.Height - (img.Height + (lineSpace * lineNum) + clMargin) If diff < 0 Then img.Height = img.Height - Abs(diff) End If 'フォント、行間を設定します With wordRange .Font.Size = fontSize .Font.ColorIndex = fontColor .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly .ParagraphFormat.LineSpacing = lineSpace '行間を設定します End With 'ルビを表示します If Not rubyFontSize = 0 Then AddRuby wordRange, rubyFontSize End If End If End Sub Sub UpdateImagesInAllColumns() '全てのセルの画像サイズ、フォントサイズを更新するプログラム Dim tbl As Table Dim cl As Cell ' 現在のドキュメントを取得します。 Set doc = ActiveDocument '　テーブルが存在した場合 If doc.Tables.Count > 0 Then ' テーブルを取得します Set tbl = doc.Tables.Item(1) '全セルの画像、テキストを修正します For Each cl In tbl.Range.Cells UpdateImagesInColumns cl Next cl End If End Sub Function FormDataDic() As Object 'フォームデータを保管するディクショナリ Dim frm As Object Dim fontBasicSize As Double Dim fontSizeTimes As Double Dim fontSize As Double Dim fontColor As Double Dim rubyFontSize As Double Dim rubyFontSizeTimes As Double 'フォームのデータを格納するディクショナリを定義します Set FormDataDic = CreateObject("Scripting.Dictionary") 'フォームを取得します Set frm = UserForm1 If frm.OptionButton1.Value = True Then '横4枚 2行2列 ' ページの向きを横向きに設定します。 FormDataDic.Add "direction", wdOrientLandscape ' テーブルの行数と列数を指定します。 FormDataDic.Add "row", 2 ' 2行 FormDataDic.Add "column", 2 ' 2列 ' ファイル名表示時の基準フォントサイズを指定 fontBasicSize = 40 ElseIf frm.OptionButton2.Value = True Then '横6枚　2行3列 FormDataDic.Add "direction", wdOrientLandscape FormDataDic.Add "row", 2 FormDataDic.Add "column", 3 fontBasicSize = 36 ElseIf frm.OptionButton3.Value = True Then '横9枚　3行4列 FormDataDic.Add "direction", wdOrientLandscape FormDataDic.Add "row", 3 FormDataDic.Add "column", 4 fontBasicSize = 25 ElseIf frm.OptionButton4.Value = True Then '横20枚　4行5列 FormDataDic.Add "direction", wdOrientLandscape FormDataDic.Add "row", 4 FormDataDic.Add "column", 5 fontBasicSize = 20 ElseIf frm.OptionButton5.Value = True Then '縦6枚　3行2列 FormDataDic.Add "direction", wdOrientPortrait FormDataDic.Add "row", 3 FormDataDic.Add "column", 2 fontBasicSize = 42 ElseIf frm.OptionButton6.Value = True Then '縦8枚　4行2列 FormDataDic.Add "direction", wdOrientPortrait FormDataDic.Add "row", 4 FormDataDic.Add "column", 2 fontBasicSize = 38 ElseIf frm.OptionButton7.Value = True Then '縦15枚　5行3列 FormDataDic.Add "direction", wdOrientPortrait FormDataDic.Add "row", 5 FormDataDic.Add "column", 3 fontBasicSize = 30 ElseIf frm.OptionButton8.Value = True Then '縦24枚　6行4列 FormDataDic.Add "direction", wdOrientPortrait FormDataDic.Add "row", 6 FormDataDic.Add "column", 4 fontBasicSize = 20 End If ' 「ファイル名を画像の下に表示する」にチェックがない時はファイル名を隠し持ちます。 If frm.CheckBox1.Value = False Then fontSize = 1 fontColor = wdWhite ElseIf frm.CheckBox1.Value = True Then ' フォントサイズ（大中小）を取得します If frm.OptionButton9.Value = True Then fontSizeTimes = 1.2 ElseIf frm.OptionButton10.Value = True Then fontSizeTimes = 1 ElseIf frm.OptionButton11.Value = True Then fontSizeTimes = 0.8 End If fontSize = fontBasicSize * fontSizeTimes fontColor = wdBlack 'ファイル名にルビを振る場合です。 If frm.CheckBox2.Value = True Then If frm.OptionButton12.Value = True Then rubyFontSizeTimes = 1.2 ElseIf frm.OptionButton13.Value = True Then rubyFontSizeTimes = 1 ElseIf frm.OptionButton14.Value = True Then rubyFontSizeTimes = 0.8 End If Else rubyFontSizeTimes = 0 End If rubyFontSize = fontSize * rubyFontSizeTimes End If FormDataDic.Add "fontSize", fontSize FormDataDic.Add "fontColor", fontColor FormDataDic.Add "rubyFontSize", rubyFontSize End Function Sub AddRuby(rng As Range, rubyFontSize As Double) 'ルビを追加するメインプログラム Dim wrdRange As Range Dim tmpText As String tmpText = "" For Each wrdRange In rng.Words '単語単位を明確にするために"_"を挿入 tmpText = tmpText & wrdRange.Text & "_" Next wrdRange rng.Text = tmpText ' ルビを振ります AddRubyForWord rng '一時的に挿入した"_"を削除します With rng.Find .Text = "_" .Execute Replace:=wdReplaceAll, replacewith:="" End With 'ルビのフォーマットを変更します ChangeRubyFormat rng, rubyFontSize End Sub Sub AddRubyForWord(rng As Range) '単語単位でルビをふるサブプログラム Dim wordRange As Range Dim charRange As Range Dim kanjiCnt As Integer Dim i As Integer ' 単語単位でルビが振られているかの判定 For Each wordRange In rng.Words kanjiCnt = 0 ' ルビはFieldで振られているか判定します。そのためルビ以外のフィールドがあると誤ります If wordRange.Fields.Count < 1 Then 'ルビが振られていなければ、 For Each charRange In wordRange.Characters '単語に漢字が含まれているかを判定します If IsKanji(charRange.Text) = True Then kanjiCnt = kanjiCnt + 1 End If Next charRange End If ' 漢字仮名混じり(漢字の文字数と単語の文字数が異なる)の場合は、一文字ずつを漢字か判定してルビを振ります If kanjiCnt > 0 And kanjiCnt < wordRange.Characters.Count Then For i = 1 To wordRange.Characters.Count If IsKanji(wordRange.Characters(i).Text) Then 'ダイアログを表示してルビを入力 wordRange.Characters(i).Select Application.Dialogs(wdDialogPhoneticGuide).Show 1 End If Next i ' 熟語(すべて漢字)であれば、ダイアログを表示 ElseIf kanjiCnt = wordRange.Characters.Count Then wordRange.Select Application.Dialogs(wdDialogPhoneticGuide).Show 1 End If Next wordRange End Sub Sub ChangeRubyFormat(rng As Range, rubyFontSize As Double) 'ルビのフォントサイズを変更するサブプログラム Dim rubyField As Field ' ルビが振られている(フィールドである)かを判定し、振られていればフォントサイズを変更 For Each rubyField In rng.Fields With rubyField.Code.Find .MatchFuzzy = False .MatchWildcards = True .Text = "hps[0-9]{1,3}" .Execute Replace:=wdReplaceAll, replacewith:="hps" & rubyFontSize End With Next rubyField End Sub Sub DeleteRuby(rng As Range) 'ルビの削除用サブプログラム Dim rubyField As Field Dim s As Long Dim e As Long ' ルビが振られている(フィールドである)かを判定し、振られていればルビを削除 For Each rubyField In rng.Fields With rubyField.Code s = .Start - 1 e = .End + 1 .SetRange s, e .PhoneticGuide Text:="" End With Next rubyField End Sub Function IsKanji(character As String) As Boolean ' 文字が漢字かどうかを判定する関数 Dim charCode As Long ' 文字列をUnicodeコードポイントに変換 charCode = Val("&H" & Hex(AscW(character)) & "&") Select Case charCode Case Val(&H4E00&) To Val(&H9FFF&) 'CJK統合漢字 IsKanji = True Case Val(&HF900&) To Val(&HFAFF&) 'CJK互換漢字 IsKanji = True Case Val(&H2E80&) To Val(&H2FDF&) 'CJK部首補助 IsKanji = True Case Val(&H3400&) To Val(&H4DBF&) 'CJK拡張A IsKanji = True Case Val(&H20000) To Val(&H2A6DF) 'CJK拡張B IsKanji = True Case Val(&H2A700) To Val(&H2B73F) 'CJK拡張C IsKanji = True Case Val(&H2F800) To Val(&H2FA1F) 'CJK互換漢字補助 IsKanji = True Case Else IsKanji = False End Select End Function Sub formOpen() 'フォームを呼び出します Dim doc As Object Dim header As HeaderFooter Dim frm As Object Dim layout As String Set doc = ActiveDocument Set frm = UserForm1 'フォームの値を初期化 frm.CommandButton3.Enabled = False frm.OptionButton1.Value = True frm.OptionButton1.Enabled = True frm.OptionButton2.Enabled = True frm.OptionButton3.Enabled = True frm.OptionButton4.Enabled = True frm.OptionButton5.Enabled = True frm.OptionButton6.Enabled = True frm.OptionButton7.Enabled = True frm.OptionButton8.Enabled = True ' 既に表が作成されている場合は現レイアウトで更新・追加となります。 ' その際に「更新」ボタンは押下可、レイアウトのラジオボタンは選択不可にします。 If doc.Tables.Count > 0 Then '現在のレイアウトをヘッダーから取得します Set header = doc.Sections(1).Headers(wdHeaderFooterPrimary) layout = Left(header.Range.Text, 4) '既存のレイアウト情報をフォームに反映します Select Case layout Case "2行2列" frm.OptionButton1.Value = True Case "2行3列" frm.OptionButton2.Value = True Case "3行4列" frm.OptionButton3.Value = True Case "4行5列" frm.OptionButton4.Value = True Case "3行2列" frm.OptionButton5.Value = True Case "4行2列" frm.OptionButton6.Value = True Case "5行3列" frm.OptionButton7.Value = True Case "6行4列" frm.OptionButton8.Value = True Case Else frm.OptionButton2.Value = True End Select ' 表の行列は変更できません frm.CommandButton3.Enabled = True frm.OptionButton1.Enabled = False frm.OptionButton2.Enabled = False frm.OptionButton3.Enabled = False frm.OptionButton4.Enabled = False frm.OptionButton5.Enabled = False frm.OptionButton6.Enabled = False frm.OptionButton7.Enabled = False frm.OptionButton8.Enabled = False End If frm.Show End Sub