' [341.xls]



' [Module1] のコード
'★★☆　特殊フォルダのフルパスを取得する　☆★★

Option Explicit

Private Declare Function APIGetWindowsDirectory& Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long)
Private Declare Function APIGetSystemDirectory& Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long)
Private Declare Function APISHGetSpecialFolderLocation& Lib "shell32.dll" Alias "SHGetSpecialFolderLocation" (ByVal hWndOwner As Long, ByVal nFolder As Long, ppidl As Long)
Private Declare Function APISHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Const CSIDL_DESKTOP = &H0
Const CSIDL_PROGRAMS = &H2
Const CSIDL_FAVORITES = &H6
Const CSIDL_STARTUP = &H7
Const CSIDL_RECENT = &H8
Const CSIDL_SENDTO = &H9
Const CSIDL_FONTS = &H14
Const CSIDL_STARTMENU = &HB

Sub start()

    UserForm1.Show

End Sub

Public Function g_fname(p_name As String, Optional fname) As String
Dim new_pname As String
Dim new_fname As String

    new_pname = p_name
    
        If Right(new_pname, 1) <> "\" Then
            new_pname = new_pname & "\"
        End If
    
        If IsMissing(fname) = True Then
            new_fname = ""
        Else
            new_fname = fname
        End If
    
    g_fname = new_pname & new_fname

End Function

'Windowsフォルダを取得
Public Function g_windir() As String
Dim r As Long
Dim buf As String
Dim ret As String

    buf = String(4096, Chr(0))

    r = APIGetWindowsDirectory(buf, Len(buf))

    ret = StrConv(LeftB(StrConv(buf, vbFromUnicode), r), vbUnicode)

    ret = g_fname(ret)

    g_windir = ret

End Function

'Systemフォルダを取得
Public Function g_sysdir() As String
Dim r As Long
Dim buf As String
Dim ret As String

    buf = String(4096, Chr(0))

    r = APIGetSystemDirectory(buf, Len(buf))

    ret = StrConv(LeftB(StrConv(buf, vbFromUnicode), r), vbUnicode)

    ret = g_fname(ret)

    g_sysdir = ret

End Function

'特殊フォルダのパス名を取得
Public Function g_specialdir(f_typ As Long) As String
Dim r As Long
Dim fold As String
Dim fold_location As Long
Dim fold_p As String
Dim ret As String

    fold = f_typ

    fold_p = String(260, Chr(0))

    r = APISHGetSpecialFolderLocation(0, fold, fold_location)

        If fold_location <> 0 Then
            r = APISHGetPathFromIDList(fold_location, fold_p)
            ret = Left(fold_p, InStr(fold_p, Chr(0)) - 1)
        Else
            ret = ""
        End If

    ret = g_fname(ret)

    g_specialdir = ret

End Function

'プログラムフォルダ
Property Get Programs() As Long
    
    Programs = CSIDL_PROGRAMS

End Property

'お気に入り
Property Get Favorites() As Long
    
    Favorites = CSIDL_FAVORITES

End Property

'スタートアップ
Property Get Startup() As Long
    
    Startup = CSIDL_STARTUP

End Property

'最近使ったファイル
Property Get Recent() As Long
    
    Recent = CSIDL_RECENT

End Property

'送る
Property Get SendTo() As Long
    
    SendTo = CSIDL_SENDTO

End Property

'デスクトップ
Property Get Desktop() As Long
    
    Desktop = CSIDL_DESKTOP

End Property

'フォント
Property Get Fonts() As Long
    
    Fonts = CSIDL_FONTS

End Property

'スタートメニュー
Property Get StartMenu() As Long
    
    StartMenu = CSIDL_STARTMENU

End Property


' [UserForm1] のコード
Option Explicit

Private Sub OptionButton1_Click()

    Label1 = g_windir

End Sub

Private Sub OptionButton10_Click()

    Label1 = g_specialdir(StartMenu)

End Sub


Private Sub OptionButton2_Click()

    Label1 = g_sysdir

End Sub

Private Sub OptionButton3_Click()

    Label1 = g_specialdir(Programs)

End Sub

Private Sub OptionButton4_Click()

    Label1 = g_specialdir(Favorites)

End Sub

Private Sub OptionButton5_Click()

    Label1 = g_specialdir(Startup)

End Sub

Private Sub OptionButton6_Click()

    Label1 = g_specialdir(Recent)

End Sub

Private Sub OptionButton7_Click()

    Label1 = g_specialdir(SendTo)

End Sub

Private Sub OptionButton8_Click()

    Label1 = g_specialdir(Desktop)

End Sub

Private Sub OptionButton9_Click()

    Label1 = g_specialdir(Fonts)

End Sub

Private Sub UserForm_Initialize()

    Me.Caption = "特殊フォルダのフルパス取得"
    Label1.Caption = ""
    
End Sub