GFShellRegistration/GFShellRegistration.bas
Attribute VB_Name = "GFShellRegistration"
Option Explicit
'(c)2001‑2003 by Louis. Use to professionally install any program under Win95/98/NT.
'Besides registration functions there are also some other functions that
'could be usable for installing or registering a program.
'
'GFGetSpecialFolderLocation
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
'GFGetShortFileName
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'GFGetLongFileName
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
'GFCreateShellLink
Private Declare Function fCreateShellLink Lib "VB5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
'GFDeleteShellLink
Private Declare Function fRemoveShellLink Lib "VB5STKIT.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long
'GFShellRegistration_GetWinDir
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'GFShellRegistration_GetWinSysDir
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
'GFShellRegistration_GetWinTempDir
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'GFShellExecute
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'GFGetSpecialFolderLocation
Private Type SHITEMID
cb As Long
abID As Byte
End Type
'GFGetSpecialFolderLocation
Private Type ITEMIDLIST
mkid As SHITEMID
End Type
'GFGetSpecialFolderLocation
Private Const MAX_PATH = 260 'disable if already existing
'GFGetSpecialFolderLocation
Public Const CSIDL_DESKTOP As Long = &H0
Public Const CSIDL_PROGRAMS As Long = &H2
Public Const CSIDL_CONTROLS As Long = &H3
Public Const CSIDL_PRINTERS As Long = &H4
Public Const CSIDL_PERSONAL As Long = &H5
Public Const CSIDL_FAVORITES As Long = &H6
Public Const CSIDL_STARTUP As Long = &H7
Public Const CSIDL_RECENT As Long = &H8
Public Const CSIDL_SENDTO As Long = &H9
Public Const CSIDL_BITBUCKET As Long = &HA
Public Const CSIDL_STARTMENU As Long = &HB
Public Const CSIDL_DESKTOPDIRECTORY As Long = &H10
Public Const CSIDL_DRIVES As Long = &H11
Public Const CSIDL_NETWORK As Long = &H12
Public Const CSIDL_NETHOOD As Long = &H13
Public Const CSIDL_FONTS As Long = &H14
Public Const CSIDL_TEMPLATES As Long = &H15
Public Const CSIDL_COMMON_STARTMENU As Long = &H16
Public Const CSIDL_COMMON_PROGRAMS As Long = &H17
Public Const CSIDL_COMMON_STARTUP As Long = &H18
Public Const CSIDL_COMMON_DESKTOPDIRECTORY As Long = &H19
Public Const CSIDL_APPDATA As Long = &H1A
Public Const CSIDL_PRINTHOOD As Long = &H1B
'end of GFGetSpecialFolderLocation
'GFShellExecute
Private Const SW_SHOW As Long = 5
'*******************************GFSHELLREGISTRATION CODE********************************
Public Function GFRegisterFileType(ByVal FileExtension As String, ByVal ExtensionName As String, ByVal ExtensionDescription As String, ByVal ApplicationName As String) As Boolean
'on error resume next 'registers a file type, returns True for success or False for error
'
'NOTE: the code was stolen from vbworld.net.
'Example: GFShellRegistration_RegisterFileType(".mp3", "Mediaplayer.MP3File", "MP3 File", "c:\winodws\mplayer.exe")
'
Rmod.RegCreateSubKeyErrorFlag = False 'reset
Call RegCreateSubKey(HKEY_CLASSES_ROOT, FileExtension)
If Rmod.RegCreateSubKeyErrorFlag = True Then GoTo Error:
Rmod.RegSetKeyValueErrorFlag = False 'reset
Call RegSetKeyValue(HKEY_CLASSES_ROOT, FileExtension, "", CVar(ExtensionName), REG_SZ)
Rmod.RegCreateSubKeyErrorFlag = False 'reset
Call RegCreateSubKey(HKEY_CLASSES_ROOT, ExtensionName + "\shell\open\command")
If Rmod.RegCreateSubKeyErrorFlag = True Then GoTo Error:
Rmod.RegSetKeyValueErrorFlag = False 'reset
Call RegSetKeyValue(HKEY_CLASSES_ROOT, ExtensionName, "", CVar(ExtensionDescription), REG_SZ)
If Rmod.RegSetKeyValueErrorFlag = True Then GoTo Error:
Rmod.RegSetKeyValueErrorFlag = False 'reset
Call RegSetKeyValue(HKEY_CLASSES_ROOT, ExtensionName + "\shell\open\command", "", CVar(ApplicationName), REG_SZ)
If Rmod.RegSetKeyValueErrorFlag = True Then GoTo Error:
GFRegisterFileType = True 'ok
Exit Function
Error:
GFRegisterFileType = False 'error
Exit Function
End Function
Public Function GFGetSpecialFolderLocation(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(0, FolderConstant, FolderIndex) = 0 Then
If SHGetPathFromIDList(FolderIndex, FolderPath) Then
Call LocalFree(FolderIndex) 'free up memory
If Not (InStr(1, FolderPath, Chr$(0), vbBinaryCompare) = 0) Then
GFGetSpecialFolderLocation = Left$(FolderPath, InStr(1, FolderPath, Chr$(0), vbBinaryCompare) ‑ 1) 'ok
Else
GFGetSpecialFolderLocation = FolderPath
End If
If Not (Right$(GFGetSpecialFolderLocation, 1) = "\") Then GFGetSpecialFolderLocation = GFGetSpecialFolderLocation + "\" 'verify
Exit Function
End If
End If
Call LocalFree(FolderIndex) 'free up memory
GFGetSpecialFolderLocation = "" 'reset (error)
Exit Function
End Function
Public Function GFGetLongFileName(ByVal Path As String) As String
'on error resume next
Dim Temp As Long
Dim Tempstr$
'begin
Tempstr$ = String(260, Chr$(0))
GFGetLongFileName = String$(MAX_PATH, Chr$(0))
Temp = GetFullPathName(Path, Len(GFGetLongFileName), GFGetLongFileName, Tempstr$)
If (Temp) Then 'verify
GFGetLongFileName = Left$(GFGetLongFileName, Temp)
Exit Function 'ok
Else
GFGetLongFileName = "" 'reset (error)
Exit Function 'error
End If
End Function
Public Function GFGetShortFileName(ByVal Path As String) As String
'on error resume next
Dim Temp As Long
'begin
GFGetShortFileName = String$(MAX_PATH, Chr$(0))
Temp = GetShortPathName(Path, GFGetShortFileName, Len(GFGetShortFileName))
If (Temp) Then 'verify
GFGetShortFileName = Left$(GFGetShortFileName, Temp)
Exit Function 'ok
Else
GFGetShortFileName = "" 'reset (error)
Exit Function 'error
End If
End Function
Public Function GFCreateShellLink(ByVal LinkTargetDirectory As String, ByVal LinkName As String, ByVal LinkApplication As String) As Boolean
'on error resume next 'creates a Win95/98/NT .lnk file; returns True for success, False for error
'
'NOTE: there is additional information at http://support.microsoft.com/support/kb/articles/Q155/3/03.asp (15‑07‑2001).
'NOTE: LinkTargetDirectory must be e.g. '..\..\Desktop' instead of 'C:\Windows\Desktop' (!?).
'
If Not (fCreateShellLink(LinkTargetDirectory, LinkName, LinkApplication, "") = 0) Then
GFCreateShellLink = True 'ok
Else
GFCreateShellLink = False 'error
End If
End Function
Public Function GFDeleteShellLink(ByVal LinkTargetDirectory As String, ByVal LinkName As String) As Boolean
'on error resume next 'deletes a Win95/98/NT .lnk file; return value unclear, do not check it
'
'NOTE: LinkTargetDirectory must be e.g. '..\..\Desktop' instead of 'C:\Windows\Desktop' (!?).
'
If Not (fRemoveShellLink(LinkTargetDirectory, LinkName) = 0) Then
GFDeleteShellLink = True 'ok
Else
GFDeleteShellLink = False 'error
End If
End Function
'
'NOTE: the GFShellRegistration_Get[Win/WinSys/WinTemp]Dir functions
'can generally be used to retrieve a special Windows‑directory,
'That means you can add this module to any kind of target project that is not be used
'to install an application but needs to use the [Win/WinSys/WinTemp]Dir.
'
Public Function GFShellRegistration_GetWinDir() As String 'use extended name to avoid conflicts
'On Error Resume Next 'returns the current Windows directory
Dim WinDir As String
WinDir = String$(260, Chr(0)) 'MAX_PATH
Call GetWindowsDirectory(WinDir, 260)
If Not (InStr(1, WinDir, Chr(0), vbBinaryCompare)) = 0 Then 'verify
WinDir = Left$(WinDir, InStr(1, WinDir, Chr(0), vbBinaryCompare) ‑ 1)
End If
If Not (Right$(WinDir, 1) = "\") Then WinDir = WinDir + "\" 'verify
GFShellRegistration_GetWinDir = WinDir
End Function
Public Function GFShellRegistration_GetWinSysDir() As String 'use extended name to avoid conflicts
'On Error Resume Next 'returns the current Windows system directory (is different on Win95/98 and WinNT)
Dim WinSysDir As String
WinSysDir = String$(260, Chr(0)) 'MAX_PATH
Call GetSystemDirectory(WinSysDir, 260)
If Not (InStr(1, WinSysDir, Chr(0), vbBinaryCompare)) = 0 Then 'verify
WinSysDir = Left$(WinSysDir, InStr(1, WinSysDir, Chr(0), vbBinaryCompare) ‑ 1)
End If
If Not (Right$(WinSysDir, 1) = "\") Then WinSysDir = WinSysDir + "\" 'verify
GFShellRegistration_GetWinSysDir = WinSysDir
End Function
Public Function GFShellRegistration_GetWinTempDir() As String 'use extended name to avoid conflicts
'On Error Resume Next 'returns the current Windows temp directory
Dim WinTempDir As String
WinTempDir = String$(260, Chr(0)) 'MAX_PATH
Call GetTempPath(260, WinTempDir)
If Not (InStr(1, WinTempDir, Chr(0), vbBinaryCompare)) = 0 Then 'verify
WinTempDir = Left$(WinTempDir, InStr(1, WinTempDir, Chr(0), vbBinaryCompare) ‑ 1)
End If
If Not (Right$(WinTempDir, 1) = "\") Then WinTempDir = WinTempDir + "\" 'verify
GFShellRegistration_GetWinTempDir = WinTempDir
End Function
Public Function GFShellExecute(ByVal ParentWindowHandle As Long, ByVal ExecuteFile As String, ByVal ExecuteParameters As String, ByVal ExecuteDirectory As String) As Boolean
'on error resume next 'returns True for success or False for error
If ShellExecute(ParentWindowHandle, "open", ExecuteFile, ExecuteParameters, ExecuteDirectory, SW_SHOW) > 32& Then 'process handle
GFShellExecute = True 'ok
Else
GFShellExecute = False 'error
End If
End Function
'****************************END OF GFSHELLREGISTRATION CODE****************************
'***MICROSOFT CODE*** (attention: not checked for being msbugsave)
'NOTE: the following Microsoft code demonstrated how one should create a shell link
'(source: http://support.microsoft.com/support/kb/articles/Q155/3/03.asp (15‑07‑2001)):
'
'Option Explicit
'
''NOTE: In Visual Basic 5.0, change Stkit432.dll in the following
''statement to Vb5stkit.dll.
'
'Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal _
' lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal _
' lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
'
'Sub Command1_Click()
'
' Dim lReturn As Long
'
' 'Add to Desktop
' lReturn = fCreateShellLink("..\..\Desktop", _
' "Shortcut to Calculator", "c:\Winnt\system32\calc.exe", "")
'
' 'Add to Program Menu Group
' lReturn = fCreateShellLink("", "Shortcut to Calculator", _
' "c:\Winnt\system32\calc.exe", "")
'
' 'Add to Startup Group
'
' 'Note that on Windows NT, the shortcut will not actually appear
' 'in the Startup group until your next reboot.
' lReturn = fCreateShellLink("\Startup", "Shortcut to Calculator", _
' "c:\Winnt\system32\calc.exe", "")
'
'End Sub
'***END OF MICROSOFT CODE***
[END OF FILE]