ショートカットファイルのリンク先を置換するマクロ
2020年11月27日
今日は、ショートカットファイルについてのお話。
会社で使うNASは、IPアドレスが変わったりフォルダの移動などで
ショートカットファイルがリンク切れを起こすケースが多々あり、
困るケースが多い。
今回は、ショートカットファイルからリンク先アドレスを取得し、
リンク先のパスを置換するマクロを作ったので紹介します。
2024/5/7追記
ソースコードだけ欲しい方は、以下の記事を参照。
「ショートカットファイルのリンク先を置換するマクロの改良～実用版～」
処理を２つに分けて、それぞれエラーチェック
ファイルのフルパスからリンク先のアドレスを取得
ファイルはあるか
拡張子は.lnkか
リンク先は生きているか
検索文字列と置換文字列を予め指定して、リンク先を修正
検索文字列があるか
置換したパスにファイルはあるか
UIを意識して、エラー内容表示とエラー箇所の網掛け表示に対応してみた。
うまくリンク先を変更した場合は、リンク前のパスはグレー文字にした。
なので、文字色と背景色も初期化する必要がある。
リンク先の存在チェックではまった。
ファイルの有無はDir関数で取得できるけど、フォルダの場合は存在するのに””を返す。
仕方なくFilseSystemObjectのサブルーチンを作って対応。
とりあえずつくったものの、大量データを入力した場合の処理速度は問題ありそう。
2023/4/23追記
リンク切れチェックについて、新しい記事を追加。
「ショートカットファイルのリンク先を置換するマクロの改良～パスの存在チェックをするバッチ～」
2024/5/7追記
リンク先取得時にエラーが出る対策について、記事を追加。
「ショートカットファイルのリンク先をショートパスで指定して文字数制限対策をした話」
上記対策をリンク先を置換するマクロに適用。
「ショートカットファイルのリンク先を置換するマクロの改良～実用版～」
以下ソース
会社で使うNASは、IPアドレスが変わったりフォルダの移動などで
ショートカットファイルがリンク切れを起こすケースが多々あり、
困るケースが多い。
今回は、ショートカットファイルからリンク先アドレスを取得し、
リンク先のパスを置換するマクロを作ったので紹介します。
2024/5/7追記
ソースコードだけ欲しい方は、以下の記事を参照。
「ショートカットファイルのリンク先を置換するマクロの改良～実用版～」
処理を２つに分けて、それぞれエラーチェック
ファイルのフルパスからリンク先のアドレスを取得
ファイルはあるか
拡張子は.lnkか
リンク先は生きているか
検索文字列と置換文字列を予め指定して、リンク先を修正
検索文字列があるか
置換したパスにファイルはあるか
UIを意識して、エラー内容表示とエラー箇所の網掛け表示に対応してみた。
うまくリンク先を変更した場合は、リンク前のパスはグレー文字にした。
なので、文字色と背景色も初期化する必要がある。
リンク先の存在チェックではまった。
ファイルの有無はDir関数で取得できるけど、フォルダの場合は存在するのに””を返す。
仕方なくFilseSystemObjectのサブルーチンを作って対応。
とりあえずつくったものの、大量データを入力した場合の処理速度は問題ありそう。
2023/4/23追記
リンク切れチェックについて、新しい記事を追加。
「ショートカットファイルのリンク先を置換するマクロの改良～パスの存在チェックをするバッチ～」
2024/5/7追記
リンク先取得時にエラーが出る対策について、記事を追加。
「ショートカットファイルのリンク先をショートパスで指定して文字数制限対策をした話」
上記対策をリンク先を置換するマクロに適用。
「ショートカットファイルのリンク先を置換するマクロの改良～実用版～」
以下ソース
Option Explicit
Sub ショートカットファイルリンク先を置換()
Dim WSH, LnkFile, DeskTopPath As String, LnkFileName As String
Set WSH = CreateObject("WScript.Shell")
Dim 検索文字列 As String: 検索文字列 = Cells(4, "C")
Dim 置換文字列 As String: 置換文字列 = Cells(5, "C")
Dim Gyo As Long, GyoSt As Long, GyoEnd As Long
GyoSt = 8
GyoEnd = Cells(Rows.Count, "B").End(xlUp).Row
'初期化処理
Range(Cells(GyoSt, "C"), Cells(Rows.Count, "F")).ClearContents
Range(Cells(GyoSt, "C"), Cells(Rows.Count, "C")).Font.Color = RGB(0, 0, 0) '文字色修正
Range(Cells(GyoSt, "B"), Cells(Rows.Count, "F")).Interior.Pattern = xlNone '網掛け解除
Dim bf_lnk As String, af_lnk As String
For Gyo = GyoSt To GyoEnd
LnkFileName = Cells(Gyo, "B").Value
If Right(LnkFileName, 4) = ".lnk" Then
If Dir(LnkFileName) <> "" Then
Set LnkFile = WSH.CreateShortcut(LnkFileName)
bf_lnk = LnkFile.TargetPath
Cells(Gyo, "C") = bf_lnk
If リンク先のチェック(bf_lnk) = 0 Then Call 黄色網掛け(Gyo, "C")
If UBound(Split(StrConv(bf_lnk, 2), StrConv(検索文字列, 2))) = 1 Then
af_lnk = Replace(bf_lnk, 検索文字列, 置換文字列, compare:=vbTextCompare)
Cells(Gyo, "D") = af_lnk
If リンク先のチェック(af_lnk) > 0 Then
LnkFile.TargetPath = af_lnk
LnkFile.Save
Cells(Gyo, "E").Value = "Complete !"
Cells(Gyo, "C").Font.Color = RGB(128, 128, 128)
Else
Cells(Gyo, "E").Value = "Replace Link Error"
Call 黄色網掛け(Gyo, "D")
End If
Else
Cells(Gyo, "E").Value = "Search Text Error " & UBound(Split(StrConv(bf_lnk, 2), StrConv(検索文字列, 2)))
End If
Else
Cells(Gyo, "E").Value = "No File"
Call 黄色網掛け(Gyo, "B")
End If
Else
Cells(Gyo, "E").Value = "Link Error"
Call 黄色網掛け(Gyo, "C")
End If 'If Right(LnkFileName, 4) = ".lnk" Then
Next Gyo
Set LnkFile = Nothing
Set WSH = Nothing
End Sub
Function リンク先のチェック(フルパス) As Long
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim flag As Long
If FSO.FileExists(フルパス) Then flag = 1
If FSO.FolderExists(フルパス) Then flag = 2
リンク先のチェック = flag
Set FSO = Nothing
End Function
Sub ショートカットファイルからリンク先を取得()
Dim WSH, LnkFile, DeskTopPath As String, LnkFileName As String
Set WSH = CreateObject("WScript.Shell")
Dim Gyo As Long, GyoSt As Long, GyoEnd As Long
GyoSt = 8
GyoEnd = Cells(Rows.Count, "B").End(xlUp).Row
For Gyo = GyoSt To GyoEnd
LnkFileName = Cells(Gyo, "B").Value
If Right(LnkFileName, 4) = ".lnk" Then
If Dir(LnkFileName) <> "" Then
Set LnkFile = WSH.CreateShortcut(LnkFileName)
Cells(Gyo, "C") = LnkFile.TargetPath
If リンク先のチェック(LnkFile.TargetPath) = 0 Then
Cells(Gyo, "E").Value = "Link OK"
Else
Cells(Gyo, "E").Value = "Link Error"
Call 黄色網掛け(Gyo, "C")
End If
Else
Cells(Gyo, "E").Value = "No File"
Call 黄色網掛け(Gyo, "B")
End If
Else
Cells(Gyo, "E").Value = "Link Error"
Call 黄色網掛け(Gyo, "C")
End If 'If Right(LnkFileName, 4) = ".lnk" Then
Next Gyo
Set LnkFile = Nothing
Set WSH = Nothing
End Sub
Sub 黄色網掛け(行, 列)
Cells(行, 列).Interior.Color = 65535
End Sub
Sub 網掛け解除(行, 列)
Cells(行, 列).Interior.Pattern = xlNone
End Sub
PR
Comment