Option Explicit
'For looking at registry keys
'To: Open key ready to look at
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
'To: Look at key
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Any, lpcbData As Long) As Long
'To: Close the key when it's finished with
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const KEY_READ = &H20019 'To allow us to READ the registry keys
'For Drawing the icon
'To: Retrieve the icon from the .EXE, .DLL or .ICO
Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
'To: Draw the icon into our picture box
Private Declare Function DrawIcon Lib "user32.dll" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
'To: Clean up after our selves (destroy the icon that "ExtractIcon" created)
Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
'For Finding the System folder
Private Declare Function GetSystemDirectory Lib "kernel32.dll" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Sub GetDefaultIcon(FileName As String, Picture_hDC As Long )
Dim TempFileName As String 'Never manipulate an input unless it doubles as an output
Dim lngError As Long 'For receiving error numbers
Dim lngRegKeyHandle As Long 'Stores the "handle" of the registry key that is currently open
Dim strProgramName As String 'Stores the contents of the first registry key
Dim strDefaultIcon As String 'Stores the contents of the second registry key
Dim lngStringLength As Long 'Sets / Returns the length of the output string
Dim lngIconNumber As Long 'Stores the icon number within a file
Dim lngIcon As Long 'Stores the "Icon Handle" for the default icon
Dim intN As Integer 'For any temporary numbers
TempFileName = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1)
If LCase(TempFileName) = ".exe" Then
strDefaultIcon = Space(260)
lngStringLength = GetSystemDirectory(strDefaultIcon, 260)
strDefaultIcon = Left(strDefaultIcon, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 2
GoTo Draw_Icon
End If
lngError = RegOpenKey(HKEY_CLASSES_ROOT, TempFileName, lngRegKeyHandle)
If lngError Then GoTo No_Icon 'we do not even have a valid extension so lets NOT try to find an icon!
lngStringLength = 260
strProgramName = Space$(260) 'Make space for the incoming string
'Get the key value:
lngError = RegQueryValueEx(lngRegKeyHandle, vbNullString, 0, 0, strProgramName, lngStringLength)
If lngError Then 'if there's an error then BIG TROUBLE so lets use the normal "windows" icon
lngError = RegCloseKey(lngRegKeyHandle) 'the world may be about to end (or just an error) but we'll clean up anyway
GoTo No_Icon
End If
lngError = RegCloseKey(lngRegKeyHandle) 'if this generates an error then we can't do anything about it anyway
strProgramName = Left(strProgramName, lngStringLength - 1) 'Cut the name down to size
'Use the value of the last key in the name of the next one (strProgramName)
lngError = RegOpenKey(HKEY_CLASSES_ROOT, strProgramName & "\DefaultIcon", lngRegKeyHandle)
If lngError Then GoTo No_Icon 'there is no icon for this extension so lets NOT try to load what doesn't exist!
'The rest is just the same as before
lngStringLength = 260
strDefaultIcon = Space$(260)
lngError = RegQueryValueEx(lngRegKeyHandle, vbNullString, 0, 0, strDefaultIcon, lngStringLength)
If lngError Then
lngError = RegCloseKey(lngRegKeyHandle)
GoTo No_Icon
End If
lngError = RegCloseKey(lngRegKeyHandle)
strDefaultIcon = Trim$(Left(strDefaultIcon, lngStringLength - 1))
intN = InStrRev(strDefaultIcon, ",") 'Find the commer
If intN < 1 Then GoTo No_Icon 'We MUST have an icon number and it will be after the ",": NO COMMA NO DEFAULT ICON
lngIconNumber = Trim$(Right(strDefaultIcon, Len(strDefaultIcon) - intN)) 'What number is after the comma
strDefaultIcon = Trim$(Left(strDefaultIcon, intN - 1)) 'We only want what's before the comma in the file name
Draw_Icon:
lngIcon = ExtractIcon(App.hInstance, strDefaultIcon, lngIconNumber) 'Extract the Icon
If lngIcon = 1 Or lngIcon = 0 Then GoTo No_Icon 'if 1 or 0 then after all that the Icon Could not be retrieved
lngError = DrawIcon(Picture_hDC, 0, 0, lngIcon) 'Draw the icon in the box
'If that was unsucessful then we can't do anything about it now!
lngError = DestroyIcon(lngIcon)
'Again we can't correct any errors now
Exit Sub
No_Icon:
'No icon could be found so we use the normal windows icon
'This icon is held in shell32.dll in the system directory, Icon 0
strDefaultIcon = Space(260)
lngStringLength = GetSystemDirectory(strDefaultIcon, 260)
strDefaultIcon = Left(strDefaultIcon, lngStringLength) & "\SHELL32.DLL"
lngIconNumber = 0
GoTo Draw_Icon
End Sub
Just incase it's not obvious, here's how to use this subroutine (Remember that you need a picture box and text box on your form). Make sure that "AutoRedraw" is set to true on your picture box:
Private Sub Command1_Click()
Picture1.Cls
GetDefaultIcon Text1.Text, Picture1.hDC
End Sub
mimo to, že se v kódu nevyznám mi to hází chyby (dal jsem tento kód do třídy Form1): Error 1 'Option' statements must precede any declarations or 'Imports' statements. 2 1 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 2 'As Any' is not supported in 'Declare' statements. 7 204 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 3 'Public ReadOnly Property Right() As Integer' has no parameters and its return type cannot be indexed. 36 24 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 4 'Public Property Left() As Integer' has no parameters and its return type cannot be indexed. 41 30 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 5 'Public Property Left() As Integer' has no parameters and its return type cannot be indexed. 57 26 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 6 'Public Property Left() As Integer' has no parameters and its return type cannot be indexed. 71 32 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 7 'Public ReadOnly Property Right() As Integer' has no parameters and its return type cannot be indexed. 75 31 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 8 'Public Property Left() As Integer' has no parameters and its return type cannot be indexed. 76 32 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 9 Name 'App' is not declared. 79 31 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 10 'Public Property Left() As Integer' has no parameters and its return type cannot be indexed. 92 26 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 11 Declaration expected. 97 1 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 12 'Cls' is not a member of 'System.Windows.Forms.PictureBox'. 100 9 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Error 13 'hDC' is not a member of 'System.Windows.Forms.PictureBox'. 101 36 C:\Documents and Settings\Tomas\Local Settings\Data aplikací\Temporary Projects\WindowsApplication2\Form1.vb WindowsApplication2 Testvoal jsem to na VB2005EE, protože 2008 má špatný den, a nechce mi povolit kliknou na tlačítko OK v dialogu New Project.
|