GFFileTypeInfo/Form1.frm

VERSION 5.00
Begin VB.Form Form1
   Caption         =   "Drop a file on form"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   3 'Windows‑Standard
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 information about a file type by scanning registry data.
'DEBUG
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)
'DEBUG
Const WM_DROPFILES = &H233
Const MAX_PATH = 260&

'***DEBUG***

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 FileTypeDescription As String
    Dim FileOpenCommand As String
    Dim FileOpenApplication As String
    Dim IconFile As String
    Dim IconIndex As Integer
    Dim Tempstr$
    'begin
    If Msg = WM_DROPFILES Then
        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
        Debug.Print ">>>" + Time$
        Debug.Print GFGetFileTypeInfo(Tempstr$, "open", FileTypeDescription, FileOpenCommand, FileOpenApplication, IconFile, IconIndex)
        Debug.Print FileTypeDescription
        Debug.Print FileOpenCommand
        Debug.Print FileOpenApplication
        Debug.Print IconFile
        Debug.Print IconIndex
        ReturnValueUsedFlag = True
        ReturnValue = 0
    End If
End Sub

Private Sub Form_Load()
    'on error resume next
    Call DragAcceptFiles(Form1.hwnd, 1)
    Call GFSubClass(Form1, "Form1", Form1, True)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'on error resume next
    Call DragAcceptFiles(Form1.hwnd, 0)
    Call GFSubClass_Terminate
End Sub

'***END OF DEBUG***

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

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]