'----------------------------- mdl-LsApi23-path ----------------------------
Option Compare Database
Option Explicit

'メモリブロックを別の領域にコピー
Declare Sub MoveMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Dest As Any, Source As Any, ByVal length&)

'パス名の最後にバックスラッシュを付加
Declare Function PathAddBackslash Lib "SHLWAPI.DLL" Alias "PathAddBackslashA" (ByVal lpszPath As String) As Long
'２つのパス名に共通するディレクトリ名を取得する
Declare Function PathCommonPrefix Lib "SHLWAPI.DLL" Alias "PathCommonPrefixA" (ByVal pszFile1 As String, ByVal pszFile2 As String, ByVal pszPath As String) As Long
'指定ファイルの存在チェック
Declare Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
'パス名を指定の長さ(ピクセル単位)に短縮する
Declare Function PathCompactPath Lib "SHLWAPI.DLL" Alias "PathCompactPathA" (ByVal hdc As Long, ByVal lpszPath As String, ByVal dx As Long) As Long
'パス名を指定の長さ(バイト)に短縮する(日本語の場合は、文字化けを起こす場合あり)
Declare Function PathCompactPathEx Lib "SHLWAPI.DLL" Alias "PathCompactPathExA" (ByVal pszOut As String, ByVal pszSrc As String, ByVal cchMax As Long, ByVal dwFlags As Long) As Long
'フルパス名から拡張子を取得（拡張子のポインタ取得）
Declare Function PathFindExtension Lib "SHLWAPI.DLL" Alias "PathFindExtensionA" (ByVal pszPath As String) As Long
'フルパス名からファイル名を取得（ファイル名のポインタ取得）
Declare Function PathFindFileName Lib "SHLWAPI.DLL" Alias "PathFindFileNameA" (ByVal pszPath As String) As Long
'指定のファイル名のフルパスを取得
Declare Function PathFindOnPath Lib "SHLWAPI.DLL" Alias "PathFindOnPathA" (ByVal pszFile As String, ppszOtherDirs As String) As Long
'ファイル名がワイルドカードを使ったファイルスペックに一致するか？
Declare Function PathMatchSpec Lib "SHLWAPI.DLL" Alias "PathMatchSpecA" (ByVal pszFileParam As String, ByVal pszSpec As String) As Long
'スペースを含むパス名は""でかこんだ文字列に変換。スペースを含まない場合は何もしない。
Declare Function PathQuoteSpaces Lib "SHLWAPI.DLL" Alias "PathQuoteSpacesA" (ByVal pszPath As String) As Long
'フルパス名からファイル拡張子を削除
Declare Function PathRemoveExtension Lib "SHLWAPI.DLL" Alias "PathRemoveExtensionA" (ByVal pszPath As String) As Long
'パス名のファイル拡張子を変更
Declare Function PathRenameExtension Lib "SHLWAPI.DLL" Alias "PathRenameExtensionA" (ByVal pszPath As String, ByVal pszExt As String) As Long
'""で囲まれたパス名から””を削除
Declare Function PathUnquoteSpaces Lib "SHLWAPI.DLL" Alias "PathUnquoteSpacesA" (ByVal pszPath As String) As Long

Function LsPathAddBackslash(strPath As String) As String
    Dim rc As Long, buf As String
    
    buf = Left$(strPath & String$(256, vbNullChar), 256)
    
    'パス名の最後にバックスラッシュを付加
    rc = PathAddBackslash(buf)
    
    LsPathAddBackslash = LsGetStr(buf)
End Function

Function LsPathCommonPrefix(pszFile1 As String, pszFile2 As String) As String
    Dim rc As Long, buf As String, pszPath As String
    
    pszPath = String$(256, vbNullChar)
    
    '２つのパス名に共通するディレクトリ名を取得する
    rc = PathCommonPrefix(pszFile1, pszFile2, pszPath)
    
    LsPathCommonPrefix = LsGetStr(pszPath)
End Function

Function LsPathCompactPath(strPath As String, dx As Long) As String
    'dx=長さ(ピクセル単位)
    Dim rc As Long, buf As String
    
    buf = Left$(strPath & String$(256, vbNullChar), 256)
    
    'パス名を指定の長さ(ピクセル単位)に短縮する
    rc = PathCompactPath(0, buf, dx)
    
    LsPathCompactPath = LsGetStr(buf)
End Function

Function LsPathCompactPathEx(strPath As String, cchMax As Long) As String
    'cchMax=長さ(バイト単位)
    Dim rc As Long, buf As String, NewPath As String
    
    buf = Left$(strPath & String$(256, vbNullChar), 256)
    NewPath = String$(256, vbNullChar)
    
    'パス名を指定の長さ(バイト)に短縮する(日本語の場合は、文字化けを起こす場合あり)
    rc = PathCompactPathEx(NewPath, buf, cchMax, 0)
    
    LsPathCompactPathEx = LsGetStr(NewPath)
End Function

Function LsPathFindExtension(strPath As String)
    Dim rc As Long
    
    'フルパス名から拡張子を取得（拡張子のポインタ取得）
    rc = PathFindExtension(strPath)
    
    'ポインタから文字列を得る
    LsPathFindExtension = LsGetStrFromPtr(rc, 256)
End Function

Public Function LsPathFindFileName(strPath As String) As String
    Dim rc As Long

    'フルパス名からファイル名を取得（ファイル名のポインタ取得）
    rc = PathFindFileName(strPath)

    'ポインタから文字列を得る
    LsPathFindFileName = LsGetStrFromPtr(rc, 256)
End Function

Function LsPathFindOnPath(ByVal pszFile As String, ByVal ppszOtherDirs As String) As String
    Dim rc As Long, buf As String, pszPath As String
    
    buf = Left$(pszFile & String$(256, vbNullChar), 256)
    
    '指定のファイル名のフルパスを取得
    rc = PathFindOnPath(buf, ppszOtherDirs)
    
    LsPathFindOnPath = LsGetStr(buf)
End Function

Function LsPathQuoteSpaces(strPath As String) As String
    Dim rc As Long, buf As String
    
    buf = Left$(strPath & String$(256, vbNullChar), 256)
    
    'スペースを含むパス名は""でかこんだ文字列に変換。スペースを含まない場合は何もしない。
    rc = PathQuoteSpaces(buf)
    
    LsPathQuoteSpaces = LsGetStr(buf)
End Function

Function LsPathRemoveExtension(strPath As String) As String
    Dim rc As Long, buf As String
    
    buf = strPath
    'フルパス名からファイル拡張子を削除
    rc = PathRemoveExtension(buf)
    
    LsPathRemoveExtension = LsGetStr(buf)
End Function

Function LsPathRenameExtension(strPath As String, strExt As String) As String
    Dim rc As Long, buf As String
    
    buf = Left$(strPath & String$(256, vbNullChar), 256)
    'パス名のファイル拡張子を変更
    rc = PathRenameExtension(buf, strExt)
    
    LsPathRenameExtension = LsGetStr(buf)
End Function

Function LsPathUnquoteSpaces(strPath As String) As String
    Dim rc As Long, buf As String
    
    buf = strPath
    
    '""で囲まれたパス名から””を削除
    rc = PathUnquoteSpaces(buf)
    
    LsPathUnquoteSpaces = LsGetStr(buf)
End Function

Public Function LsGetStrFromPtr(strExp As Long, Lenth As Long) As String
    ReDim BufArray(Lenth) As Byte
    
    MoveMemory BufArray(0), ByVal strExp, Lenth
    
    LsGetStrFromPtr = LsGetStr(StrConv(BufArray(), vbUnicode))
End Function

Public Function LsGetStr(wStr As String) As String
    Dim i As Integer
    
    i = InStr(wStr, vbNullChar)
    If i Then
      LsGetStr = Left$(wStr, i - 1)
    Else
      LsGetStr = wStr
    End If
End Function


'----------------------------- fm-LsApi23-path ----------------------------
Option Compare Database
Option Explicit

Private Sub cmd_PathAddBackslash_Click()
    Me!txtCovPath = LsPathAddBackslash(Me!txtOrgPath)
End Sub

Private Sub cmd_PathCommonPreFix_Click()
    Dim p1 As String, p2 As String, pszPath As String
    Dim msg As String
    
    'Pathは実在しなくてもかまいません
    p1 = "C:\Program Files\Common Files\Microsoft Shared\test1.exe"
    p2 = "C:\Program Files\Common Files\Microsoft Shared\DAO\DAO360.DLL"
    pszPath = LsPathCommonPrefix(p1, p2)

    msg = "パス名1=" & p1 & vbCr
    msg = msg & "パス名2=" & p2 & vbCr & vbCr
    msg = msg & "共通するディレクトリ名=" & pszPath
    MsgBox msg, vbOKOnly, Me.Caption
End Sub

Private Sub cmd_PathCompactPath_Click()
    Me!txtCovPath = LsPathCompactPath(Me!txtOrgPath, 300)
End Sub

Private Sub cmd_PathCompactPathEx_Click()
    Me!txtCovPath = LsPathCompactPathEx(Me!txtOrgPath, 50)
End Sub

Private Sub cmd_PathFileExists_Click()
    Dim p1 As String, p2 As String, rc As Long
    Dim msg As String, wFile As String
    
    p1 = "C:\WINDOWS\SYSTEM\KERNEL32.DLL"
    p2 = "C:\Program Files\Common Files\Microsoft Shared\test1.exe"
    
    msg = "ファイル名1=" & p1 & vbCr
    msg = msg & "ファイル名2=" & p2 & vbCr & vbCr
    msg = msg & "「ファイル名1」をチェックする場合は「はい」、「ファイル名2」をチェックする場合は「いいえ」をクリックしてください。"

    Select Case MsgBox(msg, vbYesNo, Me.Caption)
    Case vbYes
        wFile = p1
    Case vbNo
        wFile = p2
    Case Else
        Exit Sub
    End Select
    rc = PathFileExists(wFile)
    If rc = 1 Then
        msg = "存在します"
    Else
        msg = "見つかりません"
    End If
    MsgBox wFile & "は" & msg, vbOKOnly, Me.Caption
End Sub

Private Sub cmd_PathFindExtension_Click()
    Me!txtCovPath = LsPathFindExtension(Me!txtOrgPath)
End Sub

Private Sub cmd_PathFindFileName_Click()
    Me!txtCovPath = LsPathFindFileName(Me!txtOrgPath)
End Sub

Private Sub cmd_PathFindOnPath_Click()
    Dim wFile As String, wDir As String
    
    wFile = "Explorer.exe"
    wDir = "c:\TestDir"
    
    MsgBox wFile & "のフルパスは" & LsPathFindOnPath(wFile, wDir) & "です。", vbOKOnly, Me.Caption
End Sub

Private Sub cmd_PathMatchSpec_Click()
    Dim wFile As String, wSpc As String, msg As String
    
    wFile = "C:\WINDOWS\EXPLORER.EXE"
    wSpc = "*.exe"
    If PathMatchSpec(wFile, wSpc) = 1 Then
        msg = "します。"
    Else
        msg = "しません。"
    End If
    MsgBox wFile & "のフルパスは" & "ファイルスペック " & wSpc & " に一致" & msg, vbOKOnly, Me.Caption
End Sub

Private Sub cmd_PathQuoteSpaces_Click()
    Me!txtCovPath = LsPathQuoteSpaces(Me!txtOrgPath)
End Sub

Private Sub cmd_PathRemoveExtension_Click()
    Me!txtCovPath = LsPathRemoveExtension(Me!txtOrgPath)
End Sub

Private Sub cmd_PathRenameExtension_Click()
    Me!txtCovPath = LsPathRenameExtension(Me!txtOrgPath, ".doc")
End Sub

Private Sub cmd_PathUnquoteSpaces_Click()

    Me!txtCovPath = LsPathUnquoteSpaces("""" & Me!txtOrgPath & """")
End Sub