Last active
August 23, 2020 14:52
-
-
Save KotorinChunChun/52d5dda05f3ab31db0c0ae942adab76d to your computer and use it in GitHub Desktop.
Outlookでメール受信者がローカルパスをクリックできるようにするマクロ2
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Rem -------------------------------------------------- | |
Rem ■Outlookでメール受信者がローカルパスをクリックできるようにするマクロ2 | |
Rem | |
Rem パスをUNC表記に置き換えることでハイパーリンク化されるようにする案 | |
Rem | |
Rem えくせるちゅんちゅん | |
Rem 2019/10/22 | |
Rem https://www.excel-chunchun.com/entry/outlook-path-hyperlink-2 | |
Rem | |
Rem -------------------------------------------------- | |
Option Explicit | |
Rem 参考資料 | |
Rem ネットワークドライブからUNCを取得する例 | |
Rem http://dobon.net/vb/bbs/log3-14/8196.html | |
Rem http://blog.livedoor.jp/shingo555jp/archives/1819741.html | |
Rem WNetGetConnectionについて | |
Rem | |
Rem http://www.pinvoke.net/default.aspx/advapi32/WNetGetUniversalName.html | |
Rem Function mpr::WNetGetConnectionW | |
Rem https://retep998.github.io/doc/mpr/fn.WNetGetConnectionW.html | |
Rem Stack Overflow - Getting An Absolute Image Path | |
Rem https://stackoverflow.com/questions/19079162/getting-an-absolute-image-path/19164957 | |
Rem Passing a LPCTSTR parameter to an API call from VBA in a PTRSAFE and UNICODE safe manner | |
Rem https://stackoverflow.com/questions/10402822/passing-a-lpctstr-parameter-to-an-api-call-from-vba-in-a-ptrsafe-and-unicode-saf | |
Rem APIのAとWの置き換えについて | |
Rem RelaxTools - String型の中身は自動的にS-JISに変換される件 | |
Rem https://software.opensquare.net/relaxtools/archives/3400/ | |
Rem Programming Field - Win32APIの関数をVBで使うには… | |
Rem https://www.pg-fl.jp/program/tips/vbw32api.htm | |
Rem AddinBox - Tips26: MsgBox / Beep音 と Unicode文字列 | |
Rem http://addinbox.sakura.ne.jp/Excel_Tips26.htm | |
#If VBA7 Then | |
Private Declare PtrSafe Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionW" ( _ | |
ByVal lpszLocalName As LongPtr, _ | |
ByVal lpszRemoteName As LongPtr, _ | |
cbRemoteName As Long _ | |
) As Long | |
Rem pub unsafe extern "system" fn WNetGetConnectionW( | |
Rem lpLocalName : LPCWSTR, | |
Rem lpRemoteName : LPWSTR, | |
Rem lpnLength : LPDWORD | |
Rem ) -> DWORD | |
#Else | |
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionW" ( _ | |
ByVal lpszLocalName As Long, _ | |
ByVal lpszRemoteName As Long, _ | |
cbRemoteName As Long _ | |
) As Long | |
#End If | |
Rem http://tokovalue.jp/function/WNetGetConnection.htm | |
Rem | |
Rem WNetGetConnection | |
Rem ローカル装置に対応するネットワーク資源の名前を取得する。 | |
Rem | |
Rem パラメータ | |
Rem lpLocalName | |
Rem ネットワーク名が必要なローカル装置の名前を表す NULL で終わる文字列へのポインタを指定する。 | |
Rem lpRemoteName | |
Rem 接続に使われているリモート名を表す NULL で終わる文字列を受け取るバッファへのポインタを指定する。 | |
Rem lpnLength | |
Rem lpRemoteName パラメータが指すバッファのサイズ( 文字数)が入った変数へのポインタを指定する。 | |
Rem | |
Rem バッファのサイズが不十分で関数が失敗した場合は、必要なバッファサイズがこの変数に格納される。 | |
Rem | |
Rem 戻り値 | |
Rem 関数が成功すると、NO_ERROR が返る。 | |
Rem 関数が失敗すると、次のいずれかのエラーコードが返る。 | |
Rem | |
Rem 定数 意味 | |
Rem ERROR_BAD_DEVICE lpLocalName パラメータが指す文字列が無効である。 | |
Rem ERROR_NOT_CONNECTED lpLocalName パラメータで指定した装置がリダイレクトされていない。 | |
Rem ERROR_MORE_DATA バッファのサイズが不十分である。lpnLength パラメータが指す変数に、必要なバッファサイズが格納 | |
Rem されている。この関数で取得可能なエントリが残っている。 | |
Rem ERROR_CONNECTION_UNAVAIL 装置は現在接続されていないが、恒久的な接続として記憶されている。 | |
Rem ERROR_NO_NETWORK ネットワークにつながっていない。 | |
Rem ERROR_EXTENDED_ERROR ネットワーク固有のエラーが発生した。エラーの説明を取得するには、WNetGetLastError 関数を使う。 | |
Rem ERROR_NO_NET_OR_BAD_PATH 指定したローカル名を使った接続を認識するプロバイダがない。 | |
Rem その接続を使う1つ以上のプロバイダのネットワークにつながっていない可能性もある。 | |
Rem WNetGetConnection Return Result Constants | |
Private Const ERROR_SUCCESS As Long = 0& | |
Private Const ERROR_BAD_DEVICE As Long = 1200& | |
Private Const ERROR_NOT_CONNECTED = 2250& | |
Private Const ERROR_MORE_DATA = 234& | |
Private Const ERROR_CONNECTION_UNAVAIL = 1201& | |
Private Const ERROR_NO_NETWORK = 1222& | |
Private Const ERROR_EXTENDED_ERROR = 1208& | |
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203& | |
Rem ネットワークドライブのUNCパスを取得 | |
Rem | |
Rem @param nDriveLetter ドライブレター文字列("A:"や"Z:") | |
Rem | |
Rem @return As String 文字列 | |
Rem | |
Rem @note サーバーにアクセスできるか否かは考慮しない。 | |
Rem | |
Private Function GetUNCPath(ByVal nDriveLetter As String) As String | |
Dim UncPath As String | |
UncPath = String(1024, vbNullChar) | |
#If VBA7 Then | |
If WNetGetConnection(StrPtr(nDriveLetter), StrPtr(UncPath), LenB(UncPath)) = 0 Then | |
#Else | |
If WNetGetConnection(nDriveLetter, UncPath, LenB(UncPath)) = 0 Then | |
#End If | |
GetUNCPath = Left(UncPath, InStr(UncPath, vbNullChar) - 1) | |
End If | |
End Function | |
Sub Test_GetUNCPath() | |
Debug.Print GetUNCPath("X:") | |
End Sub | |
Rem 割当済のドライブレターとUNCパスのリストをDictionaryで返す関数 | |
Rem | |
Rem @return As Dictionary dic(ドライブレター) = UNC | |
Rem | |
Function GetNetworkDriveAndUncByAllocated() As Object | |
Dim DicDrives ' As Dictionary | |
Set DicDrives = CreateObject("Scripting.Dictionary") | |
Dim i As Long | |
Dim UncPath As String | |
For i = Asc("A") To Asc("Z") | |
UncPath = GetUNCPath(Chr(i) & ":") | |
If UncPath <> "" Then DicDrives.Add Chr(i) & ":", UncPath | |
Next | |
Set GetNetworkDriveAndUncByAllocated = DicDrives | |
End Function | |
Sub Test_GetNetworkDriveAndUncByAllocated() | |
Dim Key, Dic | |
Set Dic = GetNetworkDriveAndUncByAllocated() | |
For Each Key In Dic | |
Debug.Print Key, Dic(Key) | |
Next | |
End Sub | |
Rem 接続済のドライブレターとUNCパスのリストをDictionaryで返す関数(WSHバージョン) | |
Rem | |
Rem @return As Dictionary dic(ドライブレター) = UNC | |
Rem | |
Rem @note 接続済状態のドライブしか検出できないため | |
Rem 全てのドライブを列挙することはできない。 | |
Rem | |
Function GetNetworkDriveAndUncByConnected() As Object ' As Dictionary | |
Dim DicDrives ' As Dictionary | |
Set DicDrives = CreateObject("Scripting.Dictionary") | |
Dim Network ' As WScript.Network | |
Set Network = CreateObject("WScript.Network") | |
Rem Network.EnumNetworkDrives | |
Rem (0):=ドライブレター1, (1):=UNCパス1 | |
Rem (2):=ドライブレター2, (3):=UNCパス2 | |
Rem (4):=ドライブレター3, (5):=UNCパス3 | |
Dim Drives ' As IWshCollection | |
Set Drives = Network.EnumNetworkDrives | |
Dim i As Long | |
For i = 0 To Drives.Count - 1 Step 2 | |
If Drives.Item(i) <> "" Then | |
DicDrives.Add Drives.Item(i), Drives.Item(i + 1) | |
End If | |
Next | |
Set GetNetworkDriveAndUncByConnected = DicDrives | |
End Function | |
Sub Test_GetNetworkDriveAndUncByConnected() | |
Dim Key, Dic | |
Set Dic = GetNetworkDriveAndUncByConnected() | |
For Each Key In Dic | |
Debug.Print Key, Dic(Key) | |
Next | |
End Sub | |
Sub Test_WSH() | |
Dim NetworkDrives ' As IWshCollection | |
Set NetworkDrives = CreateObject("WScript.Network").EnumNetworkDrives | |
Dim i As Long | |
For i = 0 To NetworkDrives.Count - 1 Step 2 | |
If NetworkDrives.Item(i) <> "" Then | |
Debug.Print NetworkDrives.Item(i), NetworkDrives.Item(i + 1) | |
End If | |
Next | |
End Sub | |
Sub Test_WMI() | |
Const WQL = _ | |
"SELECT Name, ProviderName " & _ | |
"FROM Win32_LogicalDisk " & _ | |
"WHERE DriveType = 4" | |
Dim drv As WbemScripting.SWbemObject | |
For Each drv In CreateObject("WbemScripting.SWbemLocator").ConnectServer().ExecQuery(WQL) | |
With drv.Properties_ | |
Debug.Print .Item("Name").Value, .Item("ProviderName").Value | |
End With | |
Next | |
End Sub | |
Rem 接続済のドライブレターとUNCパスのリストをDictionaryで返す関数(WMIバージョン) | |
Rem | |
Rem @return As Dictionary dic(ドライブレター) = UNC | |
Rem | |
Rem @note 接続済状態のドライブしか検出できないため | |
Rem 全てのドライブを列挙することはできない。 | |
Rem | |
Function GetNetworkDriveAndUncByConnectedWMI() As Object | |
Const WQL = _ | |
"SELECT Name, ProviderName " & _ | |
"FROM Win32_LogicalDisk " & _ | |
"WHERE DriveType = 4" | |
Dim locator As WbemScripting.SWbemLocator | |
Set locator = VBA.Interaction.CreateObject("WbemScripting.SWbemLocator") | |
Dim NetworkDrives As WbemScripting.SWbemObjectSet | |
Set NetworkDrives = locator.ConnectServer().ExecQuery(WQL) | |
Dim driveDic As Dictionary | |
Set driveDic = VBA.Interaction.CreateObject("Scripting.Dictionary") | |
Dim drv As WbemScripting.SWbemObject | |
For Each drv In NetworkDrives | |
With drv.Properties_ | |
driveDic.Add .Item("Name").Value, .Item("ProviderName").Value | |
End With | |
Next | |
Set GetNetworkDriveAndUncByConnectedWMI = driveDic | |
End Function | |
Sub Test_GetNetworkDriveAndUncByConnectedWMI() | |
Dim Key, Dic | |
Set Dic = GetNetworkDriveAndUncByConnectedWMI() | |
For Each Key In Dic | |
Debug.Print Key, Dic(Key) | |
Next | |
End Sub | |
Rem コマンドプロンプトで取得する参考資料 | |
Rem | |
Rem C:\Users\USERNAME>net use | |
Rem 新しい接続は記憶されます。 | |
Rem | |
Rem ステータス ローカル名 リモート名 ネットワーク名 | |
Rem | |
Rem ------------------------------------------------------------------------------- | |
Rem 利用不可 V: \\192.168.11.1\Share Microsoft Windows Network | |
Rem 利用不可 W: \\landisk\disk Microsoft Windows Network | |
Rem OK X: \\servername-nuc\Downloads | |
Rem Microsoft Windows Network | |
Rem OK Y: \\servername-nuc\Server Microsoft Windows Network | |
Rem 利用不可 Z: \\crib35nas\Share Microsoft Windows Network | |
Rem | |
Rem ・接続済み以外も全て列挙される。 | |
Rem ・リモート名の文字数が長いと改行されて出力される。 | |
Rem -------------------------------------------------- | |
Rem ■kccFuncString | |
Rem 文字列変換関数 | |
Rem -------------------------------------------------- | |
Rem | |
Rem 抜粋 | |
Rem | |
Rem -------------------------------------------------- | |
Rem 文章中のパスと思われる文字列をハイパーリンクに対応させる関数 | |
Rem | |
Rem @param base_str 変換元文字列 | |
Rem @param DoNetDriveToUNC ネットワークドライブをUNCに変換するか否か | |
Rem False:=変換しない(既定) | |
Rem True :=変換する | |
Rem | |
Rem @return As string Outlookがハイパーリンク化可能な文字列 | |
Rem | |
Rem @example | |
Rem IN : | |
Rem 下記のファイルを御覧ください | |
Rem C:\Test\hoge.xls | |
Rem Z:\fuga.xls | |
Rem 以上 | |
Rem | |
Rem OUT : | |
Rem DoNetDriveToUNC:=False | |
Rem 下記のファイルを御覧ください | |
Rem <"file://C:\Test\hoge.xls"> | |
Rem <"file://Z:\Test\hoge.xls"> | |
Rem 以上 | |
Rem | |
Rem DoNetDriveToUNC:=True | |
Rem <"\\server\share\fuga.xls"> | |
Rem | |
Rem @note | |
Rem (Trueなら)ネットワークドライブのパスはUNCに変更することでハイパーリンク化 | |
Rem ローカルドライブのパスは <"file:// "> で囲うことでハイパーリンク化 | |
Rem UNCパスは <" "> で囲うことで途切れ防止 | |
Rem | |
Rem パスは必ず改行で終わること | |
Rem Outlookではメール送信時の自動折返しを切っておくこと | |
Rem メール作成画面ではリンク状態にはならない。 | |
Rem 自分から自分へ送信してテストするように。 | |
Rem | |
Function ReplacePathToHyperlink(base_str As String, Optional DoNetDriveToUNC As Boolean = False) As String | |
Const LocalPrefix = "file://" | |
Dim pathIdx: pathIdx = 1 | |
Dim lfIdx: lfIdx = 1 | |
Dim pathData | |
Dim v | |
Dim i As Long | |
Dim s As String | |
Dim pathHeader As String | |
Dim dicUncPath As Object 'Dictionary | |
Dim DriveLetter As String | |
'改行(CRLF)をパス終了とみなす | |
Dim base_str_arr | |
base_str_arr = Split(base_str, vbCrLf) | |
'UNCパスの変換 | |
Const UncPathPrefix = "\\" | |
For i = LBound(base_str_arr) To UBound(base_str_arr) | |
s = base_str_arr(i) | |
'UNCパスを<"UNCパス">に変換 | |
pathIdx = InStr(lfIdx, s, UncPathPrefix) | |
If pathIdx > 0 Then | |
pathData = Mid(s, pathIdx, Len(s)) | |
s = Replace(s, pathData, "<""" & pathHeader & pathData & """>") | |
base_str_arr(i) = s | |
End If | |
Next | |
'ドライブレター付きパスの変換 | |
Dim pathArr(1 To 26) | |
For i = 1 To 26: pathArr(i) = Chr(Asc("A") - 1 + i) & ":": Next | |
For i = LBound(base_str_arr) To UBound(base_str_arr) | |
s = base_str_arr(i) | |
'パスと思われる文章を検索 | |
For Each v In pathArr | |
pathIdx = InStr(lfIdx, s, LocalPrefix & v) | |
DriveLetter = v | |
If pathIdx > 0 Then Exit For | |
Next | |
If pathIdx <= 0 Then | |
For Each v In pathArr | |
pathIdx = InStr(lfIdx, s, v) | |
DriveLetter = v | |
If pathIdx > 0 Then Exit For | |
Next | |
pathHeader = LocalPrefix | |
Else | |
pathHeader = "" | |
End If | |
If pathIdx > 0 Then | |
Dim UncPath As String | |
UncPath = GetUNCPath(DriveLetter) | |
If UncPath <> "" And DoNetDriveToUNC Then | |
'ネットワークドライブのパスを<"\\ServerName\ShareName\パス">に変換(既存のfile://は消す) | |
pathData = Mid(s, pathIdx, Len(s)) | |
s = Replace(s, pathData, "<""" & Replace(pathData, DriveLetter, UncPath) & """>") | |
s = Replace(s, LocalPrefix, "") | |
base_str_arr(i) = s | |
Else | |
'ローカルドライブのパスを<"file://パス">に変換 | |
pathData = Mid(s, pathIdx, Len(s)) | |
s = Replace(s, pathData, "<""" & pathHeader & pathData & """>") | |
base_str_arr(i) = s | |
End If | |
End If | |
Next | |
'既に付与されていた場合の二重付与を解除 | |
For i = LBound(base_str_arr) To UBound(base_str_arr) | |
s = base_str_arr(i) | |
s = Replace(s, "<""<""", "<""") | |
s = Replace(s, """>"">", """>") | |
s = Replace(s, """<""", "<""") | |
s = Replace(s, """"">", """>") | |
base_str_arr(i) = s | |
Next | |
ReplacePathToHyperlink = Join(base_str_arr, vbCrLf) | |
End Function | |
Sub Test_ReplacePathToHyperlinkUnc() | |
Const TEST_STR = "aa" & vbCrLf & "X:\fuga.xls" & vbCrLf & "b" | |
' Const TEST_STR = "aa" & vbCrLf & "file://X:\hoge.xls" & vbCrLf & "b" | |
' Const TEST_STR = "aa" & vbCrLf & "\\server\Downloads\hoge.xls" & vbCrLf & "b" | |
' Const TEST_STR = "aa" & vbCrLf & "<""\\server\Downloads\hoge.xls"">" & vbCrLf & "b" | |
Dim s As String | |
s = TEST_STR | |
s = Replace(s, vbCr, "[CR]") | |
s = Replace(s, vbLf, "[LF]") | |
Debug.Print s | |
s = ReplacePathToHyperlink(TEST_STR, True) | |
s = Replace(s, vbCr, "[CR]") | |
s = Replace(s, vbLf, "[LF]") | |
Debug.Print s | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment