GFStartStation/GFStartStation.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3185
ClientLeft = 65
ClientTop = 351
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3185
ScaleWidth = 4680
StartUpPosition = 3 'Windows‑Standard
Begin VB.CommandButton GFStartStationCommand
Height = 675
Index = 4
Left = 3600
TabIndex = 3
Top = 60
Width = 735
End
Begin VB.CommandButton GFStartStationCommand
Height = 675
Index = 3
Left = 2760
TabIndex = 2
Top = 60
Width = 735
End
Begin VB.CommandButton GFStartStationCommand
Height = 675
Index = 2
Left = 1860
TabIndex = 1
Top = 60
Width = 735
End
Begin VB.CommandButton GFStartStationCommand
Height = 675
Index = 1
Left = 960
TabIndex = 0
Top = 60
Width = 735
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'GFStartStation
Private Declare Sub DragAcceptFiles Lib "shell32.dll" (ByVal hWnd As Long, ByVal fAccept As Long)
Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Sub DragFinish Lib "shell32.dll" (ByVal hDrop As Long)
'GFStartStation (icon handling and drawing)
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
'GFStartStationControlStruct ‑ general configuration (partially saved in registry)
Private Type GFStartStationControlStruct
RegMainKey As String
RegRootKey As String
BrowseApplicationName As String 'application to browse directories, by default 'explorer.exe', if not found then user is asked once to enter path of browse application
FolderIconFile As String
FolderIconIndex As Integer
ExecutableIconFile As String
ExecutableIconIndex As Integer
End Type
Dim GFStartStationControlStructVar As GFStartStationControlStruct
'GFStartStationStruct
Private Type GFStartStationStruct
StartApplicationType As Integer 'type of what was dropped
StartApplicationTypeDescription As String 'file type description of what was dropped
StartApplicationCommand As String 'path to what was dropped
StartApplicationName As String 'program to launch when command is pressed
StartAplicationIconFile As String
StartAplicationIconIndex As Integer
IconHandle As Long
End Type
Dim GFStartStationStructNumber As Integer
Dim GFStartStationStructArray() As GFStartStationStruct
'GFStartStation
Const GFSTARTSTATION_FILE As Integer = 1
Const GFSTARTSTATION_DIRECTORY As Integer = 2
'
Const WM_DROPFILES = &H233
Const MAX_PATH = 260&
'***DEBUG***
Private Sub Form_Load()
'on error resume next
Me.Show
Me.Refresh
Call GFStartStation_Initialize(HKEY_LOCAL_MACHINE, "GFStartStation Test", "shell32.dll", 20, "shell32.dll", 2)
Call GFStartStationFromReg
Call GFStartStation_RefreshAll
End Sub
Private Sub Form_Unload(Cancel As Integer)
'on error resume next
Call GFStartStation_Terminate
End Sub
Public Sub GFSubClassWindowProc(ByVal SourceDescription As String, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef ReturnValue As Long, ByRef ReturnValueUsedFlag As Boolean)
On Error Resume Next
Dim Tempstr$
'GFSTARTSTATION
Dim GFStartStationCommandIndex As Integer
If Msg = WM_DROPFILES Then 'check first to increase speed
Select Case Len(SourceDescription)
Case 24 To 29 'check first to increase speed (Integer value in brackets can have 1 to 5 chars)
If Left$(SourceDescription, 22) = "GFStartStationCommand(" Then
GFStartStationCommandIndex = Val(Mid$(SourceDescription, 23, Len(SourceDescription) ‑ 23))
If Not ((GFStartStationCommandIndex < 1) Or (GFStartStationCommandIndex > GFStartStationStructNumber)) Then 'verify
Tempstr$ = String$(MAX_PATH, Chr$(0))
Call DragQueryFile(wParam, 0, Tempstr$, MAX_PATH) 'pass True instead of 0 to get the file count (0 means receive name of first dropped file)
Call DragFinish(wParam)
If Not (InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) = 0) Then
Tempstr$ = Left$(Tempstr$, InStr(1, Tempstr$, Chr$(0), vbBinaryCompare) ‑ 1)
End If
Call GFStartStation_ReceiveFile(Tempstr$, GFStartStationCommandIndex)
ReturnValueUsedFlag = True
ReturnValue = 0
End If
End If
End Select
End If
'END OF GFSTARTSTATION
End Sub
Public Function GetFileName(ByVal GetFileNameName As String) As String 'also used by Hmod.KeyHook_Open()
On Error Resume Next 'returns chars after last backslash or nothing
Dim GetFileNameLoop As Integer
GetFileName = "" 'reset
For GetFileNameLoop = Len(GetFileNameName) To 1 Step (‑1)
If Mid$(GetFileNameName, GetFileNameLoop, 1) = "\" Then
GetFileName = Right$(GetFileNameName, Len(GetFileNameName) ‑ GetFileNameLoop)
Exit For
End If
Next GetFileNameLoop
End Function
Private Function GetFileMainName(ByVal File As String) As String
On Error Resume Next 'returns chars before last "." or File
Dim GetFileMainNameLoop As Long
GetFileMainName = File 'preset
For GetFileMainNameLoop = Len(File) To 1 Step (‑1)
If Mid$(File, GetFileMainNameLoop, 1) = "." Then
GetFileMainName = Left$(File, GetFileMainNameLoop ‑ 1)
Exit For
End If
Next GetFileMainNameLoop
End Function
'***END OF DEBUG***
'************************************GFSTARTSTATION*************************************
Private Sub GFStartStation_Initialize(ByVal RegMainKey As Long, ByVal RegRootKey As String, _
ByVal FolderIconFile As String, ByVal FolderIconIndex As Integer, ByVal ExecutableIconFile As String, ByVal ExecutableIconIndex As Integer)
'on error resume next
Dim CommandLoop As Integer
'
'NOTE: the following default values should be passed:
'FolderIconFile: shell32.dll
'FolderIconIndex: 20
'ExecutableIconFile: shell32.dll
'ExecutableIconIndex: 2
'Do not use these default values if better ones are existing
'within the target project environment.
'
'preset
If Not (Right$(RegRootKey, 1) = "\") Then RegRootKey = RegRootKey + "\"
GFStartStationControlStructVar.RegMainKey = RegMainKey
GFStartStationControlStructVar.RegRootKey = RegRootKey 'e.g. Software\MyApp\ (sub key will be added automatically)
GFStartStationControlStructVar.FolderIconFile = FolderIconFile
GFStartStationControlStructVar.FolderIconIndex = FolderIconIndex
GFStartStationControlStructVar.ExecutableIconFile = ExecutableIconFile
GFStartStationControlStructVar.ExecutableIconIndex = ExecutableIconIndex
'begin
GFStartStationStructNumber = GFStartStationCommand.UBound
If Not (GFStartStationStructNumber = 0) Then
ReDim GFStartStationStructArray(1 To GFStartStationStructNumber) As GFStartStationStruct
Else
ReDim GFStartStationStructArray(1 To 1) As GFStartStationStruct
End If
For CommandLoop = 1 To GFStartStationStructNumber
Call DragAcceptFiles(GFStartStationCommand(CommandLoop).hWnd, 1)
Call GFSubClass(GFStartStationCommand(CommandLoop), "GFStartStationCommand(" + LTrim$(Str$(CommandLoop)) + ")", Me, True)
Next CommandLoop
End Sub
Private Sub GFStartStationToReg()
'on error resume next
Dim StructLoop As Integer
'reset
Call Rmod.RegDeleteSubKey(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\")
Call Rmod.RegCreateSubKey(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\")
'begin
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "browse application", CVar(GFStartStationControlStructVar.BrowseApplicationName), REG_SZ)
For StructLoop = 1 To GFStartStationStructNumber
'NOTE: all structure elements are written, also if they contain no valid data.
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "file type" + LTrim$(Str$(StructLoop)), CVar(GFStartStationStructArray(StructLoop).StartApplicationType), REG_SZ)
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "file type description" + LTrim$(Str$(StructLoop)), CVar(GFStartStationStructArray(StructLoop).StartApplicationTypeDescription), REG_SZ)
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "application command" + LTrim$(Str$(StructLoop)), CVar(GFStartStationStructArray(StructLoop).StartApplicationCommand), REG_SZ)
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "application name" + LTrim$(Str$(StructLoop)), CVar(GFStartStationStructArray(StructLoop).StartApplicationName), REG_SZ)
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "icon file" + LTrim$(Str$(StructLoop)), CVar(GFStartStationStructArray(StructLoop).StartAplicationIconFile), REG_SZ)
Call Rmod.RegSetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "icon index" + LTrim$(Str$(StructLoop)), CVar(GFStartStationStructArray(StructLoop).StartAplicationIconIndex), REG_SZ)
Next StructLoop
End Sub
Private Sub GFStartStationFromReg()
'on error resume next
Dim StructLoop As Integer
Dim Temp As Long
'begin
GFStartStationControlStructVar.BrowseApplicationName = Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "browse application")
If GFStartStationControlStructVar.BrowseApplicationName = "" Then GFStartStationControlStructVar.BrowseApplicationName = "explorer.exe" 'preset
For StructLoop = 1 To GFStartStationStructNumber
GFStartStationStructArray(StructLoop).StartApplicationType = Val(Left$(Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "file type" + LTrim$(Str$(StructLoop))), 4)) 'use Left$() to avoid Interger overflow
GFStartStationStructArray(StructLoop).StartApplicationTypeDescription = Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "file type description" + LTrim$(Str$(StructLoop)))
GFStartStationStructArray(StructLoop).StartApplicationName = Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "application name" + LTrim$(Str$(StructLoop)))
GFStartStationStructArray(StructLoop).StartApplicationCommand = Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "application command" + LTrim$(Str$(StructLoop)))
GFStartStationStructArray(StructLoop).StartAplicationIconFile = Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "icon file" + LTrim$(Str$(StructLoop)))
Temp = Val(Left$(Rmod.RegGetKeyValue(GFStartStationControlStructVar.RegMainKey, GFStartStationControlStructVar.RegRootKey + "GFStartStation\", "icon index" + LTrim$(Str$(StructLoop))), 8)) 'use Left$() to avoid Long overflow
If Temp < ‑32767& Then Temp = ‑32767&
If Temp > 32767& Then Temp = 32767&
GFStartStationStructArray(StructLoop).StartAplicationIconIndex = CInt(Temp)
Next StructLoop
'reload icons
For StructLoop = 1 To GFStartStationStructNumber
Select Case GFStartStationStructArray(StructLoop).StartApplicationType
Case GFSTARTSTATION_DIRECTORY
Call DeleteObject(GFStartStationStructArray(StructLoop).IconHandle) 'reset
GFStartStationStructArray(StructLoop).IconHandle = ExtractIcon(App.hInstance, GFStartStationControlStructVar.FolderIconFile, GFStartStationControlStructVar.FolderIconIndex) 'stays in memory until being overwritten or until program termination
Case GFSTARTSTATION_FILE
Select Case UCase$(Right$(GFStartStationStructArray(StructLoop).StartApplicationName, 4))
Case ".EXE", ".COM"
Call DeleteObject(GFStartStationStructArray(StructLoop).IconHandle) 'reset
'first try to extract first icon from current application
GFStartStationStructArray(StructLoop).IconHandle = ExtractIcon(App.hInstance, GFStartStationStructArray(StructLoop).StartApplicationName, 0) 'try to extract the file's default icon
'if failed, extract default executable icon
If GFStartStationStructArray(StructLoop).IconHandle = 0 Then
GFStartStationStructArray(StructLoop).IconHandle = ExtractIcon(App.hInstance, GFStartStationControlStructVar.ExecutableIconFile, GFStartStationControlStructVar.ExecutableIconIndex) 'stays in memory until being overwritten or until program termination
End If
Case Else
Call DeleteObject(GFStartStationStructArray(StructLoop).IconHandle) 'reset
GFStartStationStructArray(StructLoop).IconHandle = ExtractIcon(App.hInstance, GFStartStationControlStructVar.ExecutableIconFile, GFStartStationControlStructVar.ExecutableIconIndex) 'stays in memory until being overwritten or until program termination
End Select
End Select
Next StructLoop
Exit Sub
End Sub
Private Sub GFStartStation_RefreshAll()
'on error resume next 'call to refresh all commands, e.g. after reading data from registry
Dim StructLoop As Integer
'begin
For StructLoop = 1 To GFStartStationStructNumber
Call GFStartStation_Refresh(StructLoop)
Next StructLoop
End Sub
Private Sub GFStartStation_ResetCommand(ByVal GFStartStationCommandIndex As Integer)
'on error resume next 'to be called by target project, e.g. as reaction to a pop up menu click
'verify
If (GFStartStationCommandIndex < 1) Or (GFStartStationCommandIndex > GFStartStationStructNumber) Then Exit Sub 'verify
'begin
GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationType = 0 'reset
GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationTypeDescription = "" 'reset
GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationCommand = "" 'reset
GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationName = "" 'reset
GFStartStationStructArray(GFStartStationCommandIndex).StartAplicationIconFile = "" 'reset
GFStartStationStructArray(GFStartStationCommandIndex).StartAplicationIconIndex = 0 'reset
Call DeleteObject(GFStartStationStructArray(GFStartStationCommandIndex).IconHandle)
GFStartStationStructArray(GFStartStationCommandIndex).IconHandle = 0 'reset
Call GFStartStationToReg 'save changes
Call GFStartStation_Refresh(GFStartStationCommandIndex) 'display changes
End Sub
Private Sub GFStartStation_Terminate()
'on error resume next 'call when unloading target project
Dim CommandLoop As Integer
For CommandLoop = 1 To GFStartStationStructNumber
Call DragAcceptFiles(GFStartStationCommand(CommandLoop).hWnd, 0)
Call GFSubClass_UnSubclass("GFStartStationCommand(" + LTrim$(Str$(CommandLoop)) + ")", Me)
Call DeleteObject(GFStartStationStructArray(CommandLoop).IconHandle)
Next CommandLoop
End Sub
Private Sub GFStartStationCommand_Click(Index As Integer)
On Error Resume Next 'important (if any error occurs during starting application)
Dim ApplicationName As String
Dim ApplicationDirectory As String
Dim DirectoryName As String
Dim Tempdbl#
'begin
If Not ((Index < 1) Or (Index > GFStartStationStructNumber)) Then 'verify
Select Case GFStartStationStructArray(Index).StartApplicationType
Case GFSTARTSTATION_FILE
ApplicationName = GFStartStationStructArray(Index).StartApplicationName
If Not (ApplicationName = "") Then 'verify (do not use Dir() as ApplicationName could contain parameters)
ApplicationDirectory = GetDirectoryName(ApplicationName)
If Not ((Dir(ApplicationDirectory, vbDirectory) = "") Or (ApplicationDirectory = "")) Then ChDir ApplicationDirectory 'check also for ""
Tempdbl# = Shell(ApplicationName, vbNormalFocus)
ChDir App.Path 'reset
If Tempdbl# = 0 Then MsgBox "Error starting application '" + ApplicationName + "' !", vbOKOnly + vbExclamation
End If
Case GFSTARTSTATION_DIRECTORY
DirectoryName = GFStartStationStructArray(Index).StartApplicationName
If Not (Dir(DirectoryName, vbDirectory) = "") Then 'verify
ReDo:
ApplicationDirectory = GetDirectoryName(GFStartStationControlStructVar.BrowseApplicationName)
If Not ((Dir(ApplicationDirectory, vbDirectory) = "") Or (ApplicationDirectory = "")) Then ChDir ApplicationDirectory 'check also for ""
Tempdbl# = Shell(GFStartStationControlStructVar.BrowseApplicationName + " " + DirectoryName, vbNormalFocus)
ChDir App.Path 'reset
If Tempdbl# = 0 Then
GFStartStationControlStructVar.BrowseApplicationName = InputBox("Please enter path to browse application (" + GFStartStationControlStructVar.BrowseApplicationName + " not found):", "Error during browsing", "")
If Not (GFStartStationControlStructVar.BrowseApplicationName = "") Then 'verify user didn't cancel
Call GFStartStationToReg 'save changes
GoTo ReDo:
End If
End If
End If
End Select
End If
End Sub
Private Sub GFStartStation_Refresh(ByVal GFStartStationCommandIndex As Integer)
'on error resume next 'callback sub
Dim DirectoryName As String
Dim WindowDC As Long
'
'NOTE: the content of this must be made fit to the requirements/coding possibilities
'of the target project. When this sub is called, the user dropped a valid file over
'an GFStartStationCommand, and the GFStartStationStructArray() data has been changed.
'The target project should change the appearance of the related command button.
'
'DEBUG
Select Case GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationType
Case GFSTARTSTATION_DIRECTORY
DirectoryName = GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationName
If Right$(DirectoryName, 1) = "\" Then DirectoryName = Left$(DirectoryName, Len(DirectoryName) ‑ 1)
GFStartStationCommand(GFStartStationCommandIndex).Caption = _
GetFileName(DirectoryName)
WindowDC = GetWindowDC(GFStartStationCommand(GFStartStationCommandIndex).hWnd)
Call DrawIcon(WindowDC, 0, 0, GFStartStationStructArray(GFStartStationCommandIndex).IconHandle)
Call ReleaseDC(GFStartStationCommand(GFStartStationCommandIndex).hWnd, WindowDC) 'reset (important)
Case GFSTARTSTATION_FILE
GFStartStationCommand(GFStartStationCommandIndex).Caption = _
GetFileName(GetFileMainName(GFStartStationStructArray(GFStartStationCommandIndex).StartApplicationName))
WindowDC = GetWindowDC(GFStartStationCommand(GFStartStationCommandIndex).hWnd)
Call DrawIcon(WindowDC, 0, 0, GFStartStationStructArray(GFStartStationCommandIndex).IconHandle)
Call ReleaseDC(GFStartStationCommand(GFStartStationCommandIndex).hWnd, WindowDC) 'reset (important)
End Select
'END OF DEBUG
End Sub
Private Sub GFStartStation_ReceiveFile(ByVal FilePassed As String, ByVal StartStationCommandIndex As Integer)
'on error resume next 'FilePassed can be either a file name or a directory
Dim FileTypeDescription As String
Dim FileActionCommand As String
Dim FileActionApplication As String
Dim IconFile As String
Dim IconIndex As Integer
Dim StructLoop As Integer
'verify
If Len(FilePassed) = 0 Then Exit Sub 'verify
If (StartStationCommandIndex < 1) Or (StartStationCommandIndex > GFStartStationStructNumber) Then Exit Sub 'verify
'begin
If GetAttr(FilePassed) = vbDirectory Then
If Not (Right$(FilePassed, 1) = "\") Then FilePassed = FilePassed + "\" 'verify
For StructLoop = 1 To GFStartStationStructNumber
If Not (StructLoop = StartStationCommandIndex) Then 'do not check stuff to overwrite
If UCase$(GFStartStationStructArray(StructLoop).StartApplicationName) = UCase$(FilePassed) Then
If MsgBox("You already added this browse directory, add it twice ?", vbYesNo + vbQuestion) = vbNo Then
GoTo Jump:
Else
Exit For 'don't ask twice
End If
End If
End If
Next StructLoop
GFStartStationStructArray(StartStationCommandIndex).StartApplicationType = GFSTARTSTATION_DIRECTORY
GFStartStationStructArray(StartStationCommandIndex).StartApplicationName = FilePassed
GFStartStationStructArray(StartStationCommandIndex).StartApplicationTypeDescription = "Directory"
GFStartStationStructArray(StartStationCommandIndex).StartAplicationIconFile = ""
GFStartStationStructArray(StartStationCommandIndex).StartAplicationIconIndex = 0
GFStartStationStructArray(StartStationCommandIndex).StartApplicationCommand = ""
Call DeleteObject(GFStartStationStructArray(StartStationCommandIndex).IconHandle) 'reset
GFStartStationStructArray(StartStationCommandIndex).IconHandle = ExtractIcon(App.hInstance, GFStartStationControlStructVar.FolderIconFile, GFStartStationControlStructVar.FolderIconIndex) 'stays in memory until being overwritten or until program termination
Call GFStartStation_Refresh(StartStationCommandIndex) 'display changes
Call GFStartStationToReg 'save changes
Else
Select Case UCase$(Right$(FilePassed, 4))
Case ".EXE", ".COM"
For StructLoop = 1 To GFStartStationStructNumber
If Not (StructLoop = StartStationCommandIndex) Then 'do not check stuff to overwrite
If UCase$(GFStartStationStructArray(StructLoop).StartApplicationName) = UCase$(FilePassed) Then
If MsgBox("You already added this application, add it twice ?", vbYesNo + vbQuestion) = vbNo Then
GoTo Jump:
Else
Exit For 'don't ask twice
End If
End If
End If
Next StructLoop
GFStartStationStructArray(StartStationCommandIndex).StartApplicationType = GFSTARTSTATION_FILE
GFStartStationStructArray(StartStationCommandIndex).StartApplicationTypeDescription = "Executable"
GFStartStationStructArray(StartStationCommandIndex).StartApplicationName = FilePassed
GFStartStationStructArray(StartStationCommandIndex).StartApplicationCommand = "" 'reset
GFStartStationStructArray(StartStationCommandIndex).StartAplicationIconFile = "" 'reset
GFStartStationStructArray(StartStationCommandIndex).StartAplicationIconIndex = 0 'reset
Call DeleteObject(GFStartStationStructArray(StartStationCommandIndex).IconHandle) 'reset
'first try to extract first icon from current application
GFStartStationStructArray(StartStationCommandIndex).IconHandle = ExtractIcon(App.hInstance, FilePassed, 0) 'try to extract the file's default icon
'if failed, extract default executable icon
If GFStartStationStructArray(StartStationCommandIndex).IconHandle = 0 Then
GFStartStationStructArray(StartStationCommandIndex).IconHandle = ExtractIcon(App.hInstance, GFStartStationControlStructVar.ExecutableIconFile, GFStartStationControlStructVar.ExecutableIconIndex) 'stays in memory until being overwritten or until program termination
End If
Call GFStartStation_Refresh(StartStationCommandIndex) 'display changes
Call GFStartStationToReg 'save changes
Case Else
If GFGetFileTypeInfo(FilePassed, "open", FileTypeDescription, FileActionCommand, FileActionApplication, IconFile, IconIndex) = True Then
If Len(FileActionApplication) = 0 Then 'verify
MsgBox "Sorry, this file cannot be executed !", vbOKOnly + vbInformation
GoTo Jump:
End If
For StructLoop = 1 To GFStartStationStructNumber
If Not (StructLoop = StartStationCommandIndex) Then 'do not check stuff to overwrite
If UCase$(GFStartStationStructArray(StructLoop).StartApplicationName) = UCase$(FileActionApplication) Then
If MsgBox("You already added the application '" + FileActionApplication + "', add it twice ?", vbYesNo + vbQuestion) = vbNo Then
GoTo Jump:
Else
Exit For 'don't ask twice
End If
End If
End If
Next StructLoop
GFStartStationStructArray(StartStationCommandIndex).StartApplicationType = GFSTARTSTATION_FILE
GFStartStationStructArray(StartStationCommandIndex).StartApplicationTypeDescription = FileTypeDescription
GFStartStationStructArray(StartStationCommandIndex).StartApplicationCommand = FileActionCommand
GFStartStationStructArray(StartStationCommandIndex).StartApplicationName = FileActionApplication
GFStartStationStructArray(StartStationCommandIndex).StartAplicationIconFile = IconFile
GFStartStationStructArray(StartStationCommandIndex).StartAplicationIconIndex = IconIndex
Call DeleteObject(GFStartStationStructArray(StartStationCommandIndex).IconHandle) 'reset
GFStartStationStructArray(StartStationCommandIndex).IconHandle = ExtractIcon(App.hInstance, IconFile, IconIndex) 'stays in memory until being overwritten or until program termination
Call GFStartStation_Refresh(StartStationCommandIndex) 'display changes
Call GFStartStationToReg 'save changes
Jump:
Else
MsgBox "Sorry, this file type is not associated with any application that could be started !", vbOKOnly + vbInformation 'no real error
End If
End Select
End If
End Sub
Private Function GFGetFileTypeInfo(ByVal FilePassed As String, ByVal ActionPassed As String, ByRef FileTypeDescription As String, ByRef FileActionCommand As String, ByRef FileActionApplication As String, ByRef IconFile As String, ByRef IconIndex As Integer) As Boolean
'on error resume next 'returns True if a file type is associated with passed file, False if not
Dim RemoveApplicationQutationFlag As Boolean
Dim FileTypeDescriptionInternal As String
Dim FileTypeDescriptionSubKey As String
Dim FileApplication As String
Dim FileApplicationNew As String
Dim FileIconApplication As String
Dim Temp As Long
'
'NOTE: pass 'open' for ActionPassed. Some file types don't have an open action,
'then this function will return "" as FileActionCommand and FileActionApplication.
'If it is known that 'open' will not work something else can be passed.
'NOTE: the following values are returned (var name: description)
'FileActionCommand: string read out of registry related to ActionCommand
'FileActionApplication: full path to application associated with file type ('%1' is removed, but not additional comments like '/n')
'IconFile: full path to file that contains icon related to file type
'IconIndex: index of icon in IconFile
'
'begin; read data out of registry
FileTypeDescriptionInternal = Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, "." + GetFileNameSuffix(FilePassed), "") 'e.g. Winamp.File
If Len(FileTypeDescriptionInternal) = 0 Then
GFGetFileTypeInfo = False 'error
Exit Function
End If
FileTypeDescription = Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, FileTypeDescriptionInternal, "") 'e.g. Winamp media file
FileTypeDescriptionSubKey = FileTypeDescriptionInternal: If Not (Right$(FileTypeDescriptionSubKey, 1) = "\") Then FileTypeDescriptionSubKey = FileTypeDescriptionSubKey + "\" 'verify
FileApplication = Trim$(Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, FileTypeDescriptionSubKey + "shell\" + ActionPassed + "\command", "")) 'e.g. "C:\PROGRAMME\WINAMP\WINAMP.EXE" "%1" or C:\PROGRAMME\MICROSOFT OFFICE\OFFICE\binder.exe ‑nologo %1
FileIconApplication = Trim$(Rmod.RegGetKeyValue(HKEY_CLASSES_ROOT, FileTypeDescriptionSubKey + "DefaultIcon", "")) 'e.g. C:\PROGRAMME\MICROSOFT OFFICE\OFFICE\binder.exe,3
'format read data
'NOTE: "s are removed, as well as all chars after (including) %1.
For Temp = 1 To Len(FileApplication)
If Mid$(FileApplication, Temp, 1) = """" Then
If Temp = 1 Then
RemoveApplicationQutationFlag = True
Else
If RemoveApplicationQutationFlag = True Then
RemoveApplicationQutationFlag = False 'reset
Else
Exit For
End If
End If
Else
If Mid$(FileApplication, Temp, 2) = "%1" Then
Exit For
Else
FileApplicationNew = FileApplicationNew + Mid$(FileApplication, Temp, 1)
End If
End If
Next Temp
For Temp = 1 To Len(FileIconApplication)
If Mid$(FileIconApplication, Temp, 1) = "," Then
IconFile = Left$(FileIconApplication, Temp ‑ 1)
IconIndex = Val(Right(FileIconApplication, Len(FileIconApplication) ‑ Temp))
Exit For
End If
Next Temp
'create return values
FileTypeDescription = FileTypeDescription
FileActionCommand = Trim$(FileApplication)
FileActionApplication = Trim$(FileApplicationNew)
IconFile = Trim$(IconFile)
IconIndex = IconIndex
'verify return values
'If ((Dir(FileActionApplication) = "") Or (Right$(FileActionApplication, 1) = "\") Or (FileActionApplication = "")) Then FileActionApplication = "" 'reset (error) 'no! (as e.g. C:\Command.com /p)
'If ((Dir(IconFile) = "") Or (Right$(IconFile, 1) = "\") Or (IconFile = "")) Then IconFile = "" 'reset (error) 'no! (as e.g. just 'shell32.dll')
GFGetFileTypeInfo = True 'ok
Exit Function
End Function
'*********************************END OF GFSTARTSTATION*********************************
Private Function GetDirectoryName(ByVal GetDirectoryNameName As String) As String
On Error Resume Next 'returns chars from string beginning to (including) last backslash or nothing
Dim GetDirectoryNameLoop As Integer
GetDirectoryName = "" 'reset
For GetDirectoryNameLoop = Len(GetDirectoryNameName) To 1 Step (‑1)
If Mid$(GetDirectoryNameName, GetDirectoryNameLoop, 1) = "\" Then
GetDirectoryName = Left$(GetDirectoryNameName, GetDirectoryNameLoop)
Exit For
End If
Next GetDirectoryNameLoop
End Function
Private Function GetFileNameSuffix(ByVal File As String) As String
On Error Resume Next 'returns chars after last "." or nothing
Dim GetFileNameSuffixLoop As Long
GetFileNameSuffix = "" 'reset
For GetFileNameSuffixLoop = Len(File) To 1 Step (‑1)
If Mid$(File, GetFileNameSuffixLoop, 1) = "." Then
GetFileNameSuffix = Right$(File, Len(File) ‑ GetFileNameSuffixLoop)
Exit For
End If
Next GetFileNameSuffixLoop
End Function
[END OF FILE]