PureBasic Forums - English

Posted: **Tue Jul 17, 2007 4:47 pm**

Still fiddeling with desktop+images there is a small program as a by-product whose results look nice and could be of interest to some of you. Don't look closer to the code before you didn't run it and found it nice too. The code was mixed from different locations and with the help of PB's topics on how to grab icons.

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$)

returns 0 if the directory dir$ does not contain files which fit 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

.../tomio

PureBasic Forums - English

another icon collector

another icon collector