'// FILES - READ INTERNET SHORTCUT (INI)
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'// FILES - GET FAVORITES PATH
Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByRef pIdl As Long) As Long
Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long
Private Const CSIDL_FAVORITES = &H6 'path id of favorites folder
Private Const MAX_PATH = 255 'max length path name
'// FILES - SEARCH FILES
Private Declare Function FindFirstFile Lib "kernel32.dll" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32.dll" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32.dll" (ByVal hFindFile As Long) As Long
Private Const FILE_ATTRIBUTE_HIDDEN = &H2 'file is hidden
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10 'file is directory
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type
'// MENU
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CreateMenu Lib "user32" () As Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function GetMenuString Lib "user32" Alias "GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long, ByVal lpString As String, ByVal nMaxCount As Long, ByVal wFlag As Long) As Long
Private Const MF_STRING = &H0
Private Const MF_POPUP = &H10
Private Const MF_BYPOSITION = &H400
'// WINDOW HOOK
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const WM_COMMAND = &H111
Private Const WM_MENUSELECT = &H11F
'// GLOBAL VARIABLES
Public pWndProc As Long
Public ShortCutPath() As String
Public Sub Hook(ByVal hWnd As Long, ByVal SetHook As Boolean)
If SetHook Then
pWndProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
Else
SetWindowLong hWnd, GWL_WNDPROC, pWndProc
End If
End Sub
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim liMenuID As Long
Select Case uMsg
Case WM_COMMAND 'use WM_MENUSELECT to capture MouseOver event
liMenuID = LOWORD(wParam) - 1000
If liMenuID >= 0 And liMenuID < UBound(ShortCutPath) Then
Debug.Print ShortCutPath(liMenuID)
End If
WindowProc = 1
Case Else
WindowProc = CallWindowProc(pWndProc, hWnd, uMsg, wParam, lParam)
End Select
End Function
Public Function LOWORD(ByVal dwValue As Long) As Long
Dim hexstr As String
hexstr = Right("00000000" & Hex(dwValue), 8)
LOWORD = CLng("&H" & Right(hexstr, 4))
End Function
Public Function HIWORD(ByVal dwValue As Long) As Long
Dim hexstr As String
hexstr = Right("00000000" & Hex(dwValue), 8)
HIWORD = CLng("&H" & Left(hexstr, 4))
End Function
Public Sub CreateFavoritesMenu(ByVal hWnd As Long)
Dim hMenu As Long 'handle to menu(bar)
Dim hSubMenu As Long 'handle to submenu
Dim lsPath As String
Dim pIDList As Long
'get path to favorites
If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pIDList) <> 0 Then Exit Sub
lsPath = Space$(MAX_PATH)
SHGetPathFromIDListA pIDList, lsPath
lsPath = Left$(lsPath, InStr(lsPath, vbNullChar) - 1)
'get the window's main menu (if there's no menu, create one)
hMenu = GetMenu(hWnd)
If hMenu Then DestroyMenu hMenu
hMenu = CreateMenu()
'create a submenu ("favorites")
hSubMenu = CreatePopupMenu()
If Right$(lsPath, 1) = "\" Then lsPath = Left$(lsPath, Len(lsPath) - 1)
InsertMenu hMenu, 1, MF_BYPOSITION Or MF_POPUP, hSubMenu, Mid$(lsPath, InStrRev(lsPath, "\") + 1)
'search for files
EnumFiles lsPath, hSubMenu
'append menu to window and draw menu
SetMenu hWnd, hMenu
DrawMenuBar hWnd
'start hook (not before menu is generated)
Hook frmMain.hWnd, True
End Sub
Public Sub EnumFiles(ByVal Path As String, ByVal hSubMenu As Long)
Static liMenuID As Long
Dim hFile As Long
Dim WFD As WIN32_FIND_DATA
Dim lsFileName As String
Dim hSubMenuNew As Long
If Right$(Path, 1) <> "\" Then Path = Path & "\"
hFile = FindFirstFile(Path & "*", WFD)
If hFile <> -1 Then
Do
DoEvents
lsFileName = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
If ((WFD.dwFileAttributes Or FILE_ATTRIBUTE_DIRECTORY) = WFD.dwFileAttributes) Then
'is directory
If (lsFileName <> ".") And (lsFileName <> "..") Then
'create a new sub menu
hSubMenuNew = CreatePopupMenu()
'insert it
InsertMenu hSubMenu, 0, MF_BYPOSITION Or MF_POPUP, hSubMenuNew, lsFileName
'and keep on searching..
EnumFiles Path & lsFileName, hSubMenuNew
End If
Else
'is file
If ((WFD.dwFileAttributes Or FILE_ATTRIBUTE_HIDDEN) <> WFD.dwFileAttributes) Then
'scale array of url's and add destination of current file
ReDim Preserve ShortCutPath(liMenuID)
ShortCutPath(liMenuID) = GetShortCutPath(Path & lsFileName)
'remove file extension
If Mid$(lsFileName, Len(lsFileName) - 3, 1) = "." Then
lsFileName = Left$(lsFileName, Len(lsFileName) - 4)
End If
'create a new menu item
AppendMenu hSubMenu, MF_STRING, liMenuID + 1000, lsFileName
liMenuID = liMenuID + 1
End If
End If
Loop Until FindNextFile(hFile, WFD) = 0
End If
End Sub
Public Function GetShortCutPath(ByVal FileName As String) As String
Dim lsPath As String
Dim liLength As Long
lsPath = Space$(MAX_PATH)
liLength = GetPrivateProfileString("InternetShortcut", "URL", "", lsPath, Len(lsPath), FileName)
GetShortCutPath = Left$(lsPath, liLength)
End Function
