How can I get an Icon assocated with a file, knowing only a file extension ?
Printable View
How can I get an Icon assocated with a file, knowing only a file extension ?
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpdata As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hkey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpdata As Any, lpcbData As Long) As Long
'--
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_DYN_DATA = &H80000004
Const REG_SZ = 1
Const ERROR_SUCCESS = 0&
Const ERROR_BADKEY = 1010&
Const ERROR_BADDB = 1009&
Const ERROR_CANTOPEN = 1011&
Const ERROR_CANTREAD = 1012&
Const ERROR_CANTWRITE = 1013&
Const ERROR_REGISTRY_RECOVERED = 1014&
Const ERROR_REGISTRY_CORRUPT = 1015&
Const ERROR_REGISTRY_IO_FAILED = 1016&
Const ERROR_NOT_REGISTRY_FILE = 1017&
Const ERROR_KEY_DELETED = 1018&
Const ERROR_NO_LOG_SPACE = 1019&
Const ERROR_KEY_HAS_CHILDREN = 1020&
Const ERROR_CHILD_MUST_BE_VOLATILE = 1021&
Const ERROR_RXACT_INVALID_STATE = 1369&
'---
Public Sub RegisterFileType(sExt As String, sRegType As String, sDisplay As String, sExePath As String, sCmd As String)
Dim lResult As Long
lResult = SetRegValue(HKEY_CLASSES_ROOT, sExt, "", sDesc) 'Register File Extension
'register extension shell handling
lResult = SetRegValue(HKEY_CLASSES_ROOT, sDesc, "", sDisplay)
lResult = SetRegValue(HKEY_CLASSES_ROOT, sDesc & "\DefaultIcon", "", sExePath & ",0")
lResult = SetRegValue(HKEY_CLASSES_ROOT, sDesc & "\Shell\" & sCmd & "\Command", "", sExePath & " " & Chr(34) & "%1" & Chr(34))
End Sub
Public Sub RemoveFileType(sExt As String, sRegType As String)
lResult = DeleteRegKey(HKEY_CLASSES_ROOT, sExt, "")
lResult = DeleteRegKey(HKEY_CLASSES_ROOT, sDesc, "")
End Sub
Private Function SetRegValue(lKeyRoot As Long, tRegistryKey As String, tSubKey As String, tKeyValue As String) As Long
Dim lKeyID As Long
Dim lResult As Long
SetRegValue = 0
If Len(tRegistryKey) = 0 Then
SetRegValue = ERROR_BADKEY
Exit Function
End If
lResult = RegCreateKey(lKeyRoot, tRegistryKey, lKeyID)
If lResult <> 0 Then
SetRegValue = lResult
Exit Function
End If
If Len(tKeyValue) = 0 Then
SetRegValue = RegSetValueEx(lKeyID, tSubKey, 0&, REG_SZ, 0&, 0&)
Else
SetRegValue = RegSetValueEx(lKeyID, tSubKey, 0&, REG_SZ, ByVal tKeyValue, Len(tKeyValue) + 1)
End If
End Function
Private Function DeleteRegKey(lKeyRoot As Long, tRegistryKey As String, tSubKey As String) As Long
Dim lKeyID As Long
Dim lResult As Long
DeleteRegKey = 0
If Len(tRegistryKey) = 0 Then
DeleteRegKey = ERROR_BADKEY
Exit Function
End If
lResult = RegCreateKey(lKeyRoot, tRegistryKey, lKeyID)
If lResult = 0 Then
DeleteRegKey = RegDeleteKey(lKeyID, ByVal tSubKey)
End If
End Function
Private Function CreateRegKey(sRegistryKey As String) As Long
Dim lResult As Long
CreateRegKey = 0
If Len(sRegistryKey) = 0 Then
CreateRegKey = WinRegErr.ERROR_BADKEY
Exit Function
End If
CreateRegKey = RegCreateKey(WinReg.HKEY_LOCAL_MACHINE, sRegistryKey, lResult)
End Function
Private Function DeleteRegValue(sRegistryKey As String, sSubkey As String) As Long
Dim lKeyID As Long
Dim lResult As Long
DeleteRegValue = 0
If Len(sregistryvalue) = 0 Then
DeleteRegValue = WinRegErr.ERROR_BADKEY
Exit Function
End If
If Len(sSubkey) = 0 Then
DeleteRegValue = WinRegErr.ERROR_BADKEY
Exit Function
End If
lResult = RegCreateKey(WinReg.HKEY_LOCAL_MACHINE, sRegistryKey, lKeyID)
If lResult = 0 Then
DeleteRegValue = RegDeleteValue(lKeyID, ByVal sSubkey)
End If
End Function
Private Function GetRegValue(sRegistryKey As String, sSubkey As String, sKeyValue As String) As Long
Dim lResult As Long
Dim lKeyID As Long
Dim lBufferSize As Long
GetRegValue = 0
sKeyValue = Empty
If Len(sRegistryKey) = 0 Or Len(sSubkey) = 0 Then
GetRegValue = WinRegErr.ERROR_BADKEY
Exit Function
End If
lResult = RegCreateKey(WinReg.HKEY_LOCAL_MACHINE, sRegistryKey, lKeyID)
If lResult <> 0 Then
GetRegValue = lResult
Exit Function
End If
lResult = RegQueryValueEx(lKeyID, sSubkey, 0&, WinReg.REG_SZ, 0&, lBufferSize)
If lBufferSize < 2 Then
Exit Function 'no data value available
End If
sKeyValue = String(lBufferSize + 1, " ")
lResult = RegQueryValueEx(lKeyID, sSubkey, 0&, WinReg.REG_SZ, ByVal sKeyValue, lBufferSize)
If lResult <> 0 Then
GetRegValue = lResult
Else
If InStr(1, sKeyValue, vbNullChar) > 0 Then
sKeyValue = Left(sKeyValue, lBufferSize - 1)
End If
End If
End Function
There Is A Small Mistake In The Above Code
Please Ignore WinReg. And WinRegErr. In The Above Code.
For Instance
Instead Of WinReg.HKEY_... Type Just HKEY_...