Sub MyLinkRefresh()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem ハイパーリンク先アドレス(JPEGファイル)再設定処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel 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/19:作成。
  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 *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myShell = CreateObject("Shell.Application")
  Rem [フォルダの参照]ダイアログボックス表示
  Set myBrowseFolder = myShell.BrowseForFolder(0, "ハイパーリンク先のフォルダを指定してください", 1 + 16, ActiveWorkbook.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, ActiveWorkbook.Path, "")
  mySubFolder = Replace(mySubFolder, "\", "") & "/"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  i = 0
  myMax = ActiveSheet.Hyperlinks.Count
  For Each myLink In ActiveSheet.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), ActiveWorkbook.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), ActiveWorkbook.Path & "\", "")
        End With
    End Select
  Next ' myLink
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myBrowseFolder = Nothing
  Set myShell = Nothing
  Set myScriptingFiles = Nothing
  Set myFso = Nothing
  Set myDialog = Nothing
End Sub ' MyLinkRefresh *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system