GFGetSpecialFolder/Form1.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Form1"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4635
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4635
   StartUpPosition =   3 'Windows‑Standard
   Begin VB.CommandButton Command1
      Caption         =   "Command1"
      Height          =   315
      Left            =   2460
      TabIndex        =   0
      Top             =   2820
      Width           =   2115
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001 by Louis. Use to get e.g. the start menu or programs path. Stolen from Matt Hart (www.blackbeltvb.com).
'
'IMPORTANT: see also GFShellRegistration, there is a plug‑in
'module that contains the code below.
'
'GFGetSpecialFolder
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As Any) As Long
'GFGetSpecialFolder
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type
'GFSpecialFolder
Const MAX_PATH = 260 'disable if already existing
'GFGetSpecialFolder
Private Const CSIDL_DESKTOP As Long = &H0
Private Const CSIDL_PROGRAMS As Long = &H2
Private Const CSIDL_CONTROLS As Long = &H3
Private Const CSIDL_PRINTERS As Long = &H4
Private Const CSIDL_PERSONAL As Long = &H5
Private Const CSIDL_FAVORITES As Long = &H6
Private Const CSIDL_STARTUP As Long = &H7
Private Const CSIDL_RECENT As Long = &H8
Private Const CSIDL_SENDTO As Long = &H9
Private Const CSIDL_BITBUCKET As Long = &HA
Private Const CSIDL_STARTMENU As Long = &HB
Private Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Private Const CSIDL_DRIVES As Long = &H11
Private Const CSIDL_NETWORK As Long = &H12
Private Const CSIDL_NETHOOD As Long = &H13
Private Const CSIDL_FONTS As Long = &H14
Private Const CSIDL_TEMPLATES As Long = &H15
Private Const CSIDL_COMMON_STARTMENU As Long = &H16
Private Const CSIDL_COMMON_PROGRAMS As Long = &H17
Private Const CSIDL_COMMON_STARTUP As Long = &H18
Private Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Private Const CSIDL_APPDATA As Long = &H1A
Private Const CSIDL_PRINTHOOD As Long = &H1B

Private Sub Command1_Click()
    'on error resume next
    Debug.Print GFGetSpecialFolder(CSIDL_PROGRAMS)
End Sub

Private Function GFGetSpecialFolder(ByVal FolderConstant As Long) As String
    'on error resume next 'returns the path of the special folder (e.g. start menu) or "" for error
    Dim FolderIndex As Long
    Dim FolderPath As String
    'preset
    FolderPath = String$(MAX_PATH, Chr$(0))
    'begin
    If SHGetSpecialFolderLocation(Me.hWnd, FolderConstant, FolderIndex) = 0 Then
        If SHGetPathFromIDList(FolderIndex, FolderPath) Then
            Call LocalFree(FolderIndex) 'free up memory
            GFGetSpecialFolder = FolderPath 'ok
            Exit Function
        End If
    End If
    Call LocalFree(FolderIndex) 'free up memory
    GFGetSpecialFolder = "" 'reset (error)
    Exit Function
End Function


[END OF FILE]