hInst = GetModuleHandle(BYVAL %NULL) SendMessage hDlg, %WM_SETICON, %ICON_SMALL, LoadIcon(hInst, "APP") SendMessage hDlg, %WM_SETICON, %ICON_BIG, LoadIcon(hInst, "APP")
APP ICON APP.ICO // program icon
Tweet
#Compile Exe
#Dim All
#Register None
#Include "win32api.inc"
#Include "comdlg32.inc"
' $Resource "UPDRES.PBR"
Declare Function CoInitialize Lib "ole32.dll" Alias "CoInitialize" (ByVal pvReserved As Dword) As Dword
Declare Sub CoUninitialize Lib "ole32.dll" Alias "CoUninitialize"
Declare Sub CoTaskMemFree Lib "ole32.dll" Alias "CoTaskMemFree" (pv As Dword)
Declare Function CoInitialize Lib "ole32.dll" Alias "CoInitialize" _
(ByVal pvReserved As Dword) As Dword
Declare Sub CoUninitialize Lib "ole32.dll" Alias "CoUninitialize"
Declare Sub CoTaskMemFree Lib "ole32.dll" Alias "CoTaskMemFree" (pv As Dword)
Global CatalogExe As String, CatalogDesktop As String, CatalogIco As String
Type GRPICONDIRENTRY
bWidth As Byte ' // Width, In Pixels, of the Image
bHeight As Byte ' // Height, In Pixels, of the Image
bColorCount As Byte ' // Number of colors In Image (0 If >=8bpp)
bReserved As Byte ' // Reserved
wPlanes As Word ' // Color Planes
wBitCount As Word ' // Bits per pixel
dwBytesInRes As Dword ' // how many bytes In this resource?
nID As Word ' // the ID
End Type
Type GRPICONDIR
idReserved As Word ' // Reserved (must be 0)
idType As Word ' // Resource Type (1 For icons)
idCount As Word ' // How many images?
idEntries(0) As GRPICONDIRENTRY ' // The entries For each Image
End Type
Type ICONDIR
idReserved As Word ' // Reserved (must be 0)
idType As Word ' // Resource Type (1 For icons)
idCount As Word ' // How many images?
End Type
Type ICONDIRENTRY
bWidth As Byte ' // Width, In Pixels, of the Image
bHeight As Byte ' // Height, In Pixels, of the Image
bColorCount As Byte ' // Number of colors In Image (0 If >=8bpp)
bReserved As Byte ' // Reserved ( must be 0)
wPlanes As Word ' // Color Planes
wBitCount As Word ' // Bits per pixel
dwBytesInRes As Dword ' // How many bytes In this resource?
dwImageOffset As Dword ' // Where In the file is this image?
End Type
Global ofn As OPENFILENAME, SourceModule As Asciiz * %MAX_PATH
Function GetFileNameProc (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Local rc1 As Rect, rc2 As Rect, hWnd1 As Long, hWnd2 As Long
Select Case wMsg
Case %WM_SIZE
hWnd1 = GetParent(hWnd)
' Center
hWnd2 = ofn.hWndOwner: If hWnd2 = 0 Then hWnd2 = GetDesktopWindow
GetWindowRect hWnd1, rc1: GetWindowRect hWnd2, rc2
SetWindowPos hWnd1, %HWND_TOPMOST, _
rc2.nLeft + ((rc2.nRight - rc2.nLeft) - (rc1.nRight - rc1.nLeft)) / 2, _
rc2.nTop + ((rc2.nBottom - rc2.nTop) - (rc1.nBottom - rc1.nTop)) / 2, _
0, 0, %SWP_NOSIZE
End Select
Function = DefWindowProc(hWnd, wMsg, wParam, lParam)
End Function
Function GetFileName(hWnd As Long) As String
Dim szCurDir1 As Asciiz * %MAX_PATH, szCurDir2 As Asciiz * %MAX_PATH, _
szTitleName As Asciiz * %MAX_PATH, szFilter As Asciiz * %MAX_PATH
ofn.lStructSize = SizeOf(ofn)
ofn.hWndOwner = hWnd
szFilter = "Exe Files (*.exe)" + Chr$(0) + "*.exe" + Chr$(0) + _
"Dll Files (*.dll)" + Chr$(0) + "*.dll" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
ofn.lpstrFilter = VarPtr(szFilter)
ofn.lpstrFileTitle = VarPtr(szTitleName)
ofn.nMaxFileTitle = SizeOf(szTitleName)
ofn.lpfnHook = CodePtr(GetFileNameProc)
ofn.Flags = %OFN_HIDEREADONLY Or %OFN_CREATEPROMPT Or %OFN_EXPLORER Or %OFN_ENABLEHOOK
GetCurrentDirectory SizeOf(szCurDir1), szCurDir1
GetOpenFileName ofn
GetCurrentDirectory SizeOf(szCurDir2), szCurDir2
If Right$(szCurDir2, 1) <> "\" Then szCurDir2 = szCurDir2 + "\"
If szTitleName = "" Then Function = "" Else Function = szCurDir2 + szTitleName
SetCurrentDirectory szCurDir1
End Function
Global TxtMsg As String
Function EnumResNameProc(ByVal hModule As Long, lpszType As Asciiz Ptr, lpszName As Asciiz Ptr, ByVal lParam As Long) As Long
Dim i As Long, j As Long, k As Long, kk As Long, f As Long
Dim szType As String, szName As String
If (lpszType And &HFFFF0000) Then szType = @lpszType Else szType = "#" + Format$(lpszType)
If (lpszName And &HFFFF0000) Then szName = @lpszName Else szName = "#" + Format$(lpszName)
Dim hResGrIcon As Long, hResGrIconLoad As Long, lpResGrIconLock As GRPICONDIR Ptr
Dim hResIcon As Long, hResIconLoad As Long, lpResIconLock As Long ' GRPICONDIR Ptr
Do
hResGrIcon = FindResource(hModule, @lpszName, @lpszType)
If hResGrIcon = 0 Then Exit Do
hResGrIconLoad = LoadResource(hModule, hResGrIcon)
If hResGrIconLoad = 0 Then Exit Do
lpResGrIconLock = LockResource(hResGrIconLoad)
If lpResGrIconLock = 0 Then Exit Do
k = 0
For i = 0 To @lpResGrIconLock.idCount - 1
j = @lpResGrIconLock.idEntries(i).nId
Do
hResIcon = FindResource(hModule, ByVal j, ByVal %RT_ICON)
If hResIcon = 0 Then Exit Do
hResIconLoad = LoadResource(hModule, hResIcon)
If hResIconLoad = 0 Then Exit Do
lpResIconLock = LockResource(hResIconLoad)
If lpResIconLock = 0 Then Exit Do
If i = 0 Then
Dim IconDir As ICONDIR
IconDir.idReserved = 0
IconDir.idType = 1
IconDir.idCount = @lpResGrIconLock.idCount
ReDim IconDirEntry(0 To IconDir.idCount - 1) As ICONDIRENTRY, _
IconImg(0 To IconDir.idCount - 1) As String
End If
IconDirEntry(i).bWidth = @lpResGrIconLock.idEntries(i).bWidth
IconDirEntry(i).bHeight = @lpResGrIconLock.idEntries(i).bHeight
IconDirEntry(i).bColorCount = @lpResGrIconLock.idEntries(i).bColorCount
IconDirEntry(i).bReserved = 0
IconDirEntry(i).wPlanes = @lpResGrIconLock.idEntries(i).wPlanes
IconDirEntry(i).wBitCount = @lpResGrIconLock.idEntries(i).wBitCount
IconDirEntry(i).dwBytesInRes = @lpResGrIconLock.idEntries(i).dwBytesInRes
If i = 0 Then
IconDirEntry(i).dwImageOffset = Len(ICONDIR) + IconDir.idCount * Len(ICONDIRENTRY)
Else
IconDirEntry(i).dwImageOffset = IconDirEntry(i - 1).dwImageOffset + k
End If
k = SizeofResource(hModule, hResIcon)
IconImg(i) = Peek$(lpResIconLock, k)
TxtMsg = TxtMsg + "[" + szName + "]" + Str$(j) + Str$(k) + Str$(Len(ICONDIRENTRY)) + $CRLF
Exit Do
Loop
Next
If k > 0 Then
Dim IcoData As String
IcoData = Peek$(VarPtr(IconDir), Len(ICONDIR))
For i = 0 To IconDir.idCount - 1
IcoData = IcoData + Peek$(VarPtr(IconDirEntry(i)), Len(ICONDIRENTRY))
Next
For i = 0 To IconDir.idCount - 1
IcoData = IcoData + IconImg(i)
Next
f = FreeFile
Open CatalogIco + szName + ".Ico" For Output As #f
Print #f, IcoData;
Close #f
End If
Exit Do
Loop
Function = 1
End Function
%ID_OPENSRC = 201
CallBack Function DlgProc
Select Case CbMsg
Case %WM_INITDIALOG
Control Add TextBox, CbHndl, 101, "", 5, 10, 300, 180, %WS_VSCROLL Or %ES_MULTILINE, %WS_EX_CLIENTEDGE
Control Add Button, CbHndl, %ID_OPENSRC, "Open", 320, 10, 70, 15
Case %WM_COMMAND
Dim hSourceModule As Long
If CbCtl = %ID_OPENSRC Then
Do
SourceModule = GetFileName(GetDlgItem(CbHndl, 101))
If SourceModule = "" Then MsgBox "OK": Exit Do
hSourceModule = LoadLibrary (SourceModule)
If IsFalse (hSourceModule) Then Exit Do
TxtMsg = ""
Dim IconDirId As Long
Do
CatalogIco = CatalogDesktop + "Icon_" + Format$(IconDirId) + "\"
Err = 0: MkDir CatalogIco
If Err = 0 Then Exit Do Else Incr IconDirId
Loop
EnumResourceNames hSourceModule, ByVal %RT_GROUP_ICON, CodePtr(EnumResNameProc), CbHndl
Control Set Text CbHndl, 101, TxtMsg
Dim i As Long
i = Shell ("explorer.exe " + $DQ + CatalogIco + $DQ)
Exit Do
Loop
End If
End Select
End Function
Function PbMain
Dim i As Long, pidl As Dword, TmpAsciiz As Asciiz * %MAX_PATH
CoInitialize 0
If GetModuleFileName(GetModuleHandle(ByVal 0&), TmpAsciiz, SizeOf(TmpAsciiz)) = 0 Then Exit Function
i = Instr(-1, TmpAsciiz, "\")
CatalogExe = Left$(TmpAsciiz, i)
If IsFalse(SHGetSpecialFolderLocation(ByVal %HWND_DESKTOP, ByVal %CSIDL_DESKTOP, ByVal VarPtr(pidl))) Then
SHGetPathFromIDList ByVal pidl, TmpAsciiz
If Right$(TmpAsciiz, 1) <>"\" Then CatalogDesktop = TmpAsciiz + "\" Else CatalogDesktop = TmpAsciiz
CoTaskMemFree ByVal pidl
Else
Exit Function
End If
Local hDlg As Long
Dialog New %HWND_DESKTOP, "Unload icons", , , 400, 200, %WS_CAPTION Or %WS_SYSMENU, %WS_EX_TOPMOST To hDlg
Dialog Show Modal hDlg Call DlgProc
CoUninitialize
End Function
Comment