サーバー保存先変更に伴うショートカットのリンク先変

質問

組織替えによりサーバー保存先が変わりました。
これによりフォルダーに保存されているショートカットのリンク先を変更する必要となりました。
ネット検索してもこれと言う例題が見つからなかったため、ご教示いただければと思います。

変更前共有サーバー：　\\AA\BB\CC\DD\EE\・・・・
変更後共有サーバー： \\AA\FF1\FF2\FF3\DD\EE\・・・・

変更したいことは、変更前の\\AA￥BB\CCのところを\\AA￥FF1\FF2\FF3に変更する。
\DD以降は変更なし。
１、 フォルダー内に作成したExcelファイルを保存しマクロを実行して変更する。
（デスクトップ内・サーバー内に使用）
２、 フォルダー内のlnkファイルのみを対象（数個あるとする）
３、 シートのセルD3に変更前のリンク先　\\AA\BB\CCを入力
シートのセルD5に変更する　\\AA\FF1\FF2\FF3を入力する。
（汎用性を持たせるために、セルD3・D5を変更すると他部署にも使用可能）
４、 ショートカットのリンク先先頭が,” \\AA\BB\CC“であれば\\AA\FF1\FF2\FF3に書き換える
（￥DD以降は変わらない）
５、 現在のフォルダー内だけか、下層フォルダーも変更するか　Yes/Noで選択できるようにする。
６、 ショートカットのファイル名は変更しない。

以上ですが宜しくお願いします。

ちなみに自分が作るマクロでは変数を日本語で宣言しています。　Fn　⇒　ファイル名
何か問題があるでしょうか？

回答No.2

HohoPapa · ベストアンサー

言い忘れていました。
VBA画面→ツールメニュー→参照設定で「Windows Script Host Object Model」を選択してください。

お礼

会社が休みで返信が遅れました。
Windows Script Host Object Modelを参照することでパスを変更することが出来ました。
例文が悪かったのかパスは大小文字ですが、LOGシートに記述されたパスは全て大文字でした。またショートカットのプロパティでは最初の１文字が大文字でその後はパス通りでした。それでもチャンと開きました。
有難う御座います。

回答No.1

HohoPapa

後記コードでいかがでしょうか

ただし、
作業フォルダー：WorkingDirectory　は
指定がないので何もしていません。
作業フォルダー：WorkingDirectory　にも
変更前のpathが埋まっているのではないかと思いますが
いかがでしょうか。

また、logシートに実行ログを出力するようにしました。

起動テスト程度しか行っていませんので
参考にするのであれば、しっかりテストしてからにしてください。

>ちなみに自分が作るマクロでは変数を日本語で宣言しています。
>　Fn　⇒　ファイル名
>何か問題があるでしょうか？
問題になったこともありませんし、珍しくないと思いますが
私は本能的にやりません。

Option Explicit

Dim RowCnt As Long
Dim ChgOld As String
Dim ChgNew As String
Dim RepeatFlg As Boolean

Sub ChgLnkMain()

　Dim MyPath As String
　Dim rc As Integer

　'再帰呼び出し確認
　rc = MsgBox("再帰呼び出し処理を行いますか？", vbYesNoCancel, "確認")
　If rc = vbYes Then
　　RepeatFlg = True
　ElseIf rc = vbNo Then
　　RepeatFlg = False
　Else
　　Exit Sub
　End If

　'ログシート用タイトル出力
　RowCnt = 1
　With ThisWorkbook.Sheets("Log")
　　.Cells.ClearContents
　　.Cells(RowCnt, 1).Value = "対象のショートカット"
　　.Cells(RowCnt, 2).Value = "変更前"
　　.Cells(RowCnt, 3).Value = "変更後"
　　.Cells(RowCnt, 4).Value = "実行日時"
　End With

　'変更前後の文字列を取得
　With ThisWorkbook.Sheets(1)
　　ChgOld = UCase(.Cells(3, 4).Value)
　　ChgNew = UCase(.Cells(5, 4).Value)
　End With

　'対象フォルダーを自身の配置先に設定
　MyPath = ThisWorkbook.Path & "\"

　ChgLnk MyPath

End Sub

Sub ChgLnk(MyPath As String)
　Dim buf As String
　Dim wsh As New IWshRuntimeLibrary.WshShell　'// WshShell
　Dim sc　As IWshRuntimeLibrary.WshShortcut　 '// WshShortcut
　Dim sPath As String　　　　　　　　　　　　　　　　　 '// ショートカットのパス
　Dim LinkOld As String
　Dim LinkNew As String
　Dim f As Object

　'ショートカット群を洗い、TargetPathを変更、
　buf = Dir(MyPath & "*.lnk")
　Do While buf <> ""
　　LinkOld = ""
　　LinkNew = ""

　　sPath = MyPath & buf
　　RowCnt = RowCnt + 1
　　Set sc = wsh.CreateShortcut(sPath)
　　LinkOld = UCase(sc.TargetPath)

　　If Left(LinkOld, Len(ChgOld)) = ChgOld Then
　　　LinkNew = ChgNew & Right(LinkOld, Len(LinkOld) - Len(ChgOld))
　　End If
　　If LinkNew <> "" Then
　　　sc.TargetPath = LinkNew
　　　sc.Save
　　End If

　　'ログ出力
　　With ThisWorkbook.Sheets("Log")
　　　.Cells(RowCnt, 1).Value = sPath
　　　.Cells(RowCnt, 2).Value = LinkOld
　　　.Cells(RowCnt, 3).Value = LinkNew
　　　.Cells(RowCnt, 4).Value = Now
　　End With

　　buf = Dir()
　Loop

　If RepeatFlg = False Then Exit Sub

　'再帰呼び出し
　With CreateObject("Scripting.FileSystemObject")
　　For Each f In .GetFolder(MyPath).SubFolders
　　　ChgLnk f.Path & "\"
　　Next f
　End With

End Sub

補足

HohoPapa さん、ご回答ありがとうございます。
ご返事が遅れすみません。IEではダメでEdgeにすることで返信することが出来ました。

補足です。
実行ログを出力するのは自分で何とかしようと思っていましたが、有難う御座います。
作業フォルダーはリンク切れの為か空白です。

いただいたマクロをそのままModule1コピペし、実行。
With ThisWorkbook.Sheets("Log")　で実行時エラー９
【インデックスが有効範囲にありません】
Sheets（Log）を新規追加作成し実行。

Dim wsh As New IWshRuntimeLibrary.WshShell　'// WshShell　でコンパイルエラー
【ユーザー定義型は定義されていません】
となりました。

宜しくお願いします。