Sub MyLinkRefresh() Rem *----*----* *----*----* *----*----* *----*----* Rem ハイパーリンク先アドレス(JPEGファイル)再設定処理 Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Word VBA Rem 機能... Rem 指定した保存先フォルダのJPEGファイルを、文書中のハイパーリンクの表示文字列で検索し、 Rem 当該ハイパーリンクのアドレスを総て再設定する。 Rem (ハイパーリンク先のファイル名を変更した後に、この処理を実行して再設定する。) Rem 注記... Rem 1. この処理は、文書を一度以上保存した場合に有効。 Rem (新規作成して保存を一度もしていない場合は、使用不可。) Rem 2. 指定したフォルダの「*.jpg」ファイルを検索し、ハイパーリンクのアドレスに設定する。 Rem 3. 指定するフォルダは、文書ファイルと同一か下位のフォルダであること。 Rem 4. 検索するファイルは、次のようなファイル名の場合に有効: Rem 検索する文字列(=ハイパーリンクの表示文字列)と任意の文字列が、 Rem つながっている場合は検索不可。 Rem (「ああ」は、検索する文字列(=ハイパーリンクの表示文字列)、 Rem 「いい」は、内容・長さとも任意の文字列、 Rem 「00」「01」は、内容・長さとも任意の数字) Rem ああ.jpg 00ああ.jpg ああ01.jpg 00ああ01.jpg Rem ああ01いい.jpg 00ああ01いい.jpg Rem 5. 検索したファイルが全くない場合も、ダイアログボックスが表示されるので、 Rem 縮小版表示されたファイルを直にクリックして選択すること。 Rem [キャンセル]ボタンを押すと、処理を中止する。 Rem 6. 検索したファイルが複数ある場合は、ダイアログボックスが表示されるので、 Rem 縮小版表示されたファイルを直にクリックして選択すること。 Rem この際、[ファイル名]は、検索したファイルの名前が総て表示されたままになっているので注意。 Rem [キャンセル]ボタンを押すと、処理を中止する。 Rem [ファイル名]・[空白ボタン]は、使用不可。 Rem 履歴... Rem 第01版:2007/04/04:作成。 Rem *----*----* *----*----* *----*----* *----*----* Rem 参照設定する場合... Rem Microsoft Shell Controls And Automation Rem Microsoft Scripting RunTime Rem Microsoft VBScript Regular Expressions 5.5 Rem *----*----* *----*----* *----*----* *----*----* Dim myShell As Variant ' Shell32.Shell Dim myBrowseFolder As Variant ' Shell32.Folder Dim myFolder As String ' Dim myFso As Variant ' Scripting.FileSystemObject Dim myScriptingFiles As Variant ' Scripting.Files Dim myScriptingFile As Variant ' Scripting.File ' Dim myFiles As String Dim myString As String Dim myLink As Hyperlink Dim mySubFolder As String ' Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp Dim myMatches As Variant ' MatchCollection Dim myMatch As Variant ' Match Dim myPttn As String ' Dim myDialog As FileDialog Dim myInitialFileName As String Dim myText As String Dim myHref As String Dim i As Long Dim myMax As Long Rem *----*----* *----*----* *----*----* *----*----* ' Selection.HomeKey wdStory, wdMove ' Set myShell = CreateObject("Shell.Application") Rem [フォルダの参照]ダイアログボックス表示 Set myBrowseFolder = myShell.BrowseForFolder(0, "ハイパーリンク先のフォルダを指定してください", 1 + 16, ActiveDocument.Path) If myBrowseFolder Is Nothing Then Exit Sub Else myFolder = myBrowseFolder.Items.Item.Path End If ' Set myFso = CreateObject("Scripting.FileSystemObject") Rem ファイルを名を取り込む Set myScriptingFiles = myFso.GetFolder(myFolder).Files myFiles = vbCrLf For Each myScriptingFile In myScriptingFiles If Right(myScriptingFile, 4) = ".jpg" Then myFiles = myFiles & myScriptingFile.Name & vbCrLf End If Next ' myScriptingFile If myFiles = vbCrLf Then MsgBox "JPEGファイル(*.jpg)がありません。" Exit Sub End If ' Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp mySubFolder = Replace(myFolder, ActiveDocument.Path, "") mySubFolder = Replace(mySubFolder, "\", "") & "/" Rem *----*----* *----*----* *----*----* *----*----* ' i = 0 myMax = ActiveDocument.Hyperlinks.Count For Each myLink In ActiveDocument.Hyperlinks i = i + 1 myLink.Range.Select myText = i * 100 \ myMax & "% " & i & "/" & myMax & "件" Application.StatusBar = "MyLinkRefresh" & ":" & myText ' myPttn = "(\r\n){1}(\d*?)(" & myLink.TextToDisplay & ")(\d*?|\d+?.*?)\.jpg" With myRegExp .Pattern = myPttn ' パターンを指定 .IgnoreCase = False ' 大文字小文字を区別する。 .Global = True ' 文字列全体を検索 End With Set myMatches = myRegExp.Execute(myFiles) ' Select Case myMatches.Count Case 1 myHref = Replace(myMatches(0).Value, vbCrLf, "") myLink.Address = mySubFolder & myHref Case 0 ' MsgBox "該当するJPEGファイル(*.jpg)がありません。" Set myDialog = Application.FileDialog(msoFileDialogFilePicker) With myDialog .InitialView = msoFileDialogViewThumbnail .ButtonName = " " .Filters.Add "画像", "*.jpg", 1 .InitialFileName = "" myText = " ( " & i & "/" & myMax & "件目" & " )" .Title = myLink.TextToDisplay & myText & ":画像を一つ選択し、クリックして下さい。(ファイル名・空白ボタンは無効)" .AllowMultiSelect = False If .Show = 0 Then Rem [キャンセル] Set myDialog = Nothing Exit Sub End If myLink.Address = Replace(.SelectedItems(1), ActiveDocument.Path & "\", "") End With Case Else ' MsgBox "該当するJPEGファイル(*.jpg)が複数あります。" myInitialFileName = "" For Each myMatch In myMatches myInitialFileName = myInitialFileName & Replace(myMatch.Value, vbCrLf, "") & ";" Next ' myMatch ' Set myDialog = Application.FileDialog(msoFileDialogFilePicker) With myDialog .InitialView = msoFileDialogViewThumbnail .ButtonName = " " .Filters.Add "画像", "*.jpg", 1 ' InitialFileNameプロパティに 256 文字より長い文字列を指定すると、実行時エラーになります。 .InitialFileName = Left(myFolder & "\" & myInitialFileName, 256) myText = " ( " & i & "/" & myMax & "件目" & " )" .Title = myLink.TextToDisplay & myText & ":画像を一つ選択し、クリックして下さい。(ファイル名・空白ボタンは無効)" .AllowMultiSelect = False If .Show = 0 Then Rem [キャンセル] Set myDialog = Nothing Exit Sub End If myLink.Address = Replace(.SelectedItems(1), ActiveDocument.Path & "\", "") End With End Select Next ' myLink Rem *----*----* *----*----* *----*----* *----*----* ' Selection.HomeKey wdStory, wdMove ' Set myBrowseFolder = Nothing Set myShell = Nothing Set myScriptingFiles = Nothing Set myFso = Nothing Set myDialog = Nothing End Sub ' MyLinkRefresh *----*----* *----*----* *----*----* *----*----*