The program collects the icons of all exe-files of the directory\... of your choice.
You'll have the opportunity to learn the source-exe and icon-number of selected icons and to save it (as bmp).
Aha: the code runs with PB 4.02 on XP, not with older versions.
The reason (which took me a lot of trouble, because I have a new and an old PB in use (I had!)):
In the previous version
Code: Select all
ExamineDirectory(i,dir$,pattern$)For most fun select directories with MANY icons!
Code: Select all
;
Global Wd,Rd,icB,icH,imtH,ic$ ,imt
Procedure.s NextFile(dir$,pat$)
;each call returns the next path\file according pattern pat$
;The procedure allows to separate mainloop and NextFileCall.
;file order:
; all files in a newly found subdir first.
; then next subdir.
;dir$="" -> reset
;dir$<>old-dir$ -> reset+start
;dir$="%" -> abbr for old-dir$
;return = "" -> end-of-list
;
Static lvl=0,stat,d$,p$,d0$ ;lvl=SubDirLevel==#Directory
If dir$="" Or (dir$<>"%" And dir$<>d0$) ;reset or new list?
d$="": d0$=dir$
;close all Directories still open:
While lvl>0:If IsDirectory(lvl): FinishDirectory(lvl):lvl-1:EndIf:Wend
If dir$="": ProcedureReturn:EndIf
EndIf
;start with top-level
If d$="":
d$=dir$:p$=pat$:lvl+1
If ExamineDirectory(lvl, d$, p$)=0: ProcedureReturn "":EndIf
EndIf
;subdirectory-walk:
Repeat
;d$ is beeing examined. List all (matching) files first:
n$="" ;suche alle Files(nichtVerzeichnisse) in diesem Verzeichnis
While NextDirectoryEntry(lvl)
If DirectoryEntryType(lvl) = #PB_DirectoryEntry_File
n$=DirectoryEntryName(lvl)
Break ;found a file
EndIf
Wend
If n$<>"":ProcedureReturn d$+n$: EndIf
;no more files, now the subdirs:
;reopen the dir to begin from start:
FinishDirectory(lvl):
i=ExamineDirectory(lvl, d$, "*.*")
;the following repeatloop is left when another subdir was found:
;there are 2 possibilities:
;a)there is another subdir in the current dir
;b)no more subdirs in the current dir -> go 1 dir up(=back)
Repeat
ii=0:jj=0: e1$=""
;look for another subdir in the current dir:
Repeat
jj=NextDirectoryEntry(lvl): If jj=0: Break:EndIf
e$=DirectoryEntryName(lvl):
If DirectoryEntryType(lvl) = #PB_DirectoryEntry_Directory
If PeekB(@e$)<>'.'
d$+e$+"\": ii=1
Break ;found another subdir
EndIf
EndIf
Until jj=0 ;no more entries in current dir
If ii=0:
FinishDirectory(lvl):lvl-1: ;no subdir found-->1 level up
d$=Left(d$,Len(d$)-1): d$=GetPathPart(d$)
Else
lvl+1:ExamineDirectory(lvl, d$, p$) ;next subdir found
EndIf
Until ii<>0 Or lvl=0 ;either new subdir or start-dir reached
Until lvl=0 ;if start-dir reached--> end
d$=""
ProcedureReturn ""
EndProcedure
;
Procedure examine_ico()
;a)show the icon's exe, b)save it as bmp
Static flip$=""
SetGadgetText(imt,"examine->LeftClick, continue->RightClick, Save->DoubleLeft")
SetGadgetColor(imt,#PB_Gadget_BackColor,#Red)
Repeat
Ev = WindowEvent() :If Ev=0:Delay(5):EndIf
If Ev=#PB_Event_CloseWindow: ProcedureReturn 99:EndIf
iwt=EventType()
If iwt=#PB_EventType_RightClick:EndIf
If iwt=#PB_EventType_LeftClick Or iwt=#PB_EventType_LeftDoubleClick
ix=(WindowMouseX(wd)-Rd)/icB: iy=(WindowMouseY(wd)-Rd-imtH)/icH
t$=","+Str(ix)+":"+Str(iy)+"%"
i=FindString(ic$,t$,1)
t1$=StringField(StringField(Mid(ic$,i+1,120),1,","),2,"%")
SetGadgetText(imt,t1$)
SetGadgetColor(imt,#PB_Gadget_BackColor,#Yellow)
If iwt=#PB_EventType_LeftDoubleClick
; 1012 0:1% K:\spiele\SnakeZ\uninstall.exe:0
flic=Val(StringField(t1$,3,":"))
fli$=StringField(t1$,1,":")+":"+StringField(t1$,2,":")
flin$=StringField(StringField(t1$,2,":"),1,".")
flin$=flip$+"ico_"+ReplaceString(flin$,"\","_")+".bmp"
fl$ = SaveFileRequester("Save ico as bitmap to....",flin$,"ico2bmp|*.bmp",0)
If fl$<>"":
flip$=GetPathPart(fl$):
ico=ExtractIcon_(WindowID(wd),fli$,flic)
icobmp=CreateImage(#PB_Any,32,32)
StartDrawing(ImageOutput(icobmp))
Box(0,0,32,32,#White)
DrawImage(ico,0,0)
StopDrawing()
DestroyIcon_(ico)
SaveImage(icobmp,fl$)
FreeImage(icobmp)
EndIf
EndIf
EndIf
Until iwt=#PB_EventType_RightClick
SetGadgetColor(imt,#PB_Gadget_BackColor,#Yellow)
EndProcedure
;
NextFileP$="*.exe" ;search exefiles only
;------------------------------------------------
icc0=RGB(249, 247, 182):icc1=RGB(209, 207, 122):
icB=40:icH=40:imB=10*icB:imH=10*icH: ff.f=imB/icB: icp=(ff*imH)/icH
im=CreateImage(#PB_Any,imB,imH)
imID=ImageID(im)
Rd=2:imtH=20:wdB=imB+2*Rd:wdH=imH+2*Rd+imtH
Wd=OpenWindow(#PB_Any,100,100,wdB,wdH,"ICON pager",#PB_Window_SystemMenu )
WdID=WindowID(wd)
CreateGadgetList(WdID)
imt=StringGadget(#PB_Any,Rd,0,imB,imtH,"",#PB_String_ReadOnly)
in$=""
Repeat
;loop til user selects no directory
exa=0:icc=icc0
SetGadgetColor(imt,#PB_Gadget_BackColor,#Yellow)
StartDrawing(ImageOutput(im)):Box(0,0,imB,imH,icc):StopDrawing()
img=ImageGadget(#PB_Any,Rd,Rd+imtH,imB,imH,imID)
;select a directory to search for icons:
Repeat
in$=PathRequester("select a path",in$)
If in$="":End:EndIf
If FileSize(in$)=-2
;count the EXEfiles, no need to do, for userinfo only
SetGadgetColor(imt,#PB_Gadget_BackColor,#Green)
SetGadgetText(imt,"wait, I'm counting exe files...")
For i=1 To 20:WindowEvent():Next
NextFileN$=in$
SetWindowTitle(Wd,"ICON pager "+NextFileN$)
ii=0:While Nextfile(NextFileN$,NextFileP$)<>"": ii+1:Wend
SetGadgetColor(imt,#PB_Gadget_BackColor,#Yellow)
icz=ii:pgs=ii/icp
SetGadgetText(imt,Str(ii)+" exe files found in "+in$)
EndIf
Until ii>0
Nextfile("","")
icx=-40: icy=0:ic$=",":icz=0
Repeat
Ev = WindowEvent() :If Ev=0:Delay(5):EndIf
If Ev=#PB_Event_CloseWindow: End:EndIf
NextFile$=Nextfile(NextFileN$,NextFileP$)
;imagegadget full? -> give user a chance to save
If NextFile$="": exa=examine_ico():
Else
icoZ=ExtractIcon_(WdID,NextFile$,-1) ; 0=first icon/1=2nd icon
If icoZ>0
flz+1
ic=icoZ
For i=1 To icoZ
ico=ExtractIcon_(WindowID(wd),NextFile$,i-1)
If icx+icB>wdB-40:icx=0:icy+icH:Else:icx+icB:EndIf
If icy>imH-40 : exa=examine_ico()
icx=0: icy=0:ic$=",": If icc=icc0: icc=icc1:Else:icc=icc0:EndIf
EndIf
If ico
StartDrawing(ImageOutput(im))
icz+1
SetWindowTitle(Wd,"ICON pager "+NextFileN$+" "+Str(icz)+" "+Str(flz))
Box(icx,icy,icB,icH,icc)
DrawImage(ico,icx,icy)
StopDrawing()
EndIf
SetGadgetState(img,imID):
ic$+Str((icx+1)/icB)+":"+Str((icy+1)/icH)+"%"+NextFile$+":"+Str(i-1)+","
DestroyIcon_(ico)
Next
EndIf
EndIf
Until Ev=#PB_Event_CloseWindow Or NextFile$="" Or exa=99
Until 1=2