A vfp grid filer with files icons attached as ListView

Published on by Yousfi Benameur


In the previous post i attached  to the grid the icons of the associated application only.these groups many icons for all kind of controls/windows.
In this post each file have its proper icon (for ex scx,prg, app,frx,h,vcx, ....and so).
this is not ever done previously from any vfp grid code and its an absolutly a new method .
this code shows a directory files in a vfp grid as the windows ListView looks like (iconed)
the new  is to make original icon beside the file in grid (there is some hints in news2news but with  listView as windows explorer does).
All knows cannot position directly for each row an image or icon in grid.Must rescue to  dynamicBackcolor,dynamicForecolor...to place the icons in one gesture.
in the grid,any file extension file have the correspondant icon as windows explorer does exactly in its frames.
this code creates icons from file extension and shows it in first column.
it uses the API shGetFileInfo to retrieve for any file extension the hIcon handle.
then with gdiplusX can built real icon from its handle.make the system.app in source folder (to avoid dialog locate..).
all files icons are created and gathered in a temporarly folder "icons",destroyed at the end of application(releasing form).

select any folder  (simple search files or recursively in subfolders) and go.
Note: for background image internet must be connected.
credits to  http://www.news2news.com/vfp/?group=-1&function=1074  SHGetFileInfo API permit me to start with this project.

*get any folder in dialog
*can check the recurse folder if the case (include subfolders)
*can order ascending or descending by click on any header (column>=2)
*can fire the main menu for -statistics of the current main
                            -gridlines(cycle in 0-1-2-3)+set grid.Hilightsyle
                            -Selected files properties
                            -grid fontsize
                            -search/hilight  any word with ygsearch class in grid
                            -export to html report (can use  beautified css styles see my previous codes-i used here genhtml.prg as (_genhtml) with some bgcolors).
*any row have a contextuel menu   -edit file
                                  -open selected folder
                                  -run file with associated application (shellexecute)
                                  -copy field,file properties,all row fields
*Elements shown in grid are: filename,folder,size (bytes),DateLastModified,RTimeLasModified,Attributes (as ADir() function  can provides).

*there is a pure API method i work on,complet  and publish in next post.
*this code was rendered for a 32 pouces screen.
*note: initially i used stylized html reports but the code is too long for this editor capacity...i shorted it.

post [255]


Click on code to select [then copy] -click outside to deselect


*1* created on wednesday 17 of January  2018
*this is not ever done previously from any vfp code and its an absolutly  new method.
*this code shows a directory files in a vfp grid as the windows ListView does (iconed)
*the new (i dont see it anywhere before) is to make original icon beside the file in grid (there is some hints in news2news but a a listView as windows explorer does).
*any windows extension file have the correspondant icon as windows explorer does exactly in its frames.
*this code creates icons from file extension and shows it in first column.
*select an folder and go.
*for background image internt must be connected.
*credits to  http://www.news2news.com/vfp/?group=-1&function=1074  SHGetFileInfo API permit me to start with this project

Set Safe Off
set talk off
set date short
Close Data All
Clea Resources
with _screen
.addProperty("t0",seconds())
.addproperty("Ellapsed",0)
endwith

Public oform1
oform1=Newobject("ygrid_icons")
oform1.Show
read events
Return

Define Class ygrid_icons As Form
  Height = 516
  Width = 990
  ShowWindow=2
  AutoCenter = .T.
  windowstate=2
  Caption = "Grid filer with original icons of files"
  Name = "Form1"

  Add Object grid1 As Grid With ;
    Anchor=15,;
    Height = 478-15, ;
    Left = 2, ;
    Top = 36, ;
    Width = 958, ;
    fontsize=8,;
    scrollbars=2,;
    visible=.f.,;
    Name = "Grid1"

  Add Object command1 As CommandButton With ;
    Top = 2, ;
    Left = 24, ;
    Height = 25, ;
    Width = 61, ;
    Caption = "Getdir", ;
    MousePointer = 15, ;
    Name = "Command1"

  Add Object ymenu As CommandButton With ;
    Top = 2, ;
    Left = 395, ;
    Height = 25, ;
    Width = 65, ;
    Caption = "Menu", ;
    MousePointer = 15, ;
    Name = "ymenu"

  Add object check1 as checkbox with ;
  left= 495  ,;
  top= 2   ,;
  caption="Recurse folder",;
  value=0,;
  autosize=.t.,;
  name="check1"

  Add object ylab as label with;
  top=2,;
  left=620,;
  autosize=.t.,;
  height=22,;
  forecolor=255,;
  backstyle=0,;
  caption="",;
  name="ylab"

   Add object ystat as label with;
   anchor=768,;
  top=490+12,;
  left=10,;
  autosize=.t.,;
  height=22,;
  forecolor=rgb(255,0,0),;
  backstyle=0,;
  caption="",;
  name="ystat"

  Add Object text1 As TextBox With ;
    top=2,;
    left=90,;
    width=300,;
    height=24,;
    fontsize=8,;
    readonly=.T.,;
    value="",;
    name="text1"

  ADD OBJECT image1 AS image WITH ;
	Stretch = 2, ;
	Height = 48, ;
	Left = 118, ;
	Top = 629, ;
	Width = 48, ;
	backstyle=0,;
	visible=.f.,;
	Name = "Image1"

   ADD OBJECT yf AS image WITH ;
    Anchor=15,;
	Stretch = 2, ;
	Left = 0, ;
	Top = 0, ;
	width= 990,;
	height=516 , ;
	picture="", ;
	Name = "yf"

  Procedure Load
    Declare Integer SHGetFileInfo In shell32;
      STRING pszPath,;
      LONG dwFileAttributes,;
      STRING @psfi,;
      LONG cbFileInfo,;
      LONG uFlags
    Declare SHORT DestroyIcon In user32 Integer hIcon
    &&shellexecute
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow

    Do Locfile("system.app","app")   &&system.app must be preferably in source folder.
  Endproc

  Procedure Destroy
    Try
      Erase m.yrep0+"icons\*.*"
      Rd m.yrep0+"icons"
    Catch
    Endtry

    m.yrep0=Null
    Release m.yrep0
    Clea Dlls
    oform1=Null
    Release oform1
    Clea Events
  Endproc

  Procedure Init
    Publi  m.yrep0
    m.yrep0=Addbs(Justpath(Sys(16,1) ))
    If ! Directory(m.yrep0+"icons")
      Md (m.yrep0+"icons")
    Else
      Erase (m.yrep0+"icons\*.*")
    Endi

    Local loRequest,m.lcUrl   &&if no internet can any big image  as form.picture
m.lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20180118/ob_a1e145_yfonds.jpg"
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
with thisform.yf
.pictureval=m.loRequest.ResponseBody
.width=.parent.width
.height=.parent.height
.zorder(1)
endwith
m.loRequest=Null

   with thisform.image1
   .left=720
   .top=5
   endwith
thisform.resize
  Endproc

  Procedure command1.Click
    Local m.yrep
    m.yrep=Getdir(Addbs(Justpath(Sys(16,1))),"","",32)
    If Empty(m.yrep)
      Return .F.
    Endi
thisform.image1.visible=.t.
thisform.grid1.visible=.f.
thisform.mousepointer=11
    _screen.t0=seconds()
     m.yrep=Addbs(m.yrep)
    Thisform.text1.Value=m.yrep
    Create Cursor ycurs (Icon c(200),Filename c(100),cPath c(200),XSIZE i,DateLM d,TimeLM c(10),xAttr c(5))
  if thisform.check1.value=1
=RecurseFolder( m.yrep )
thisform.ylab.caption=trans(reccount())+" files"
else
    Local gnbre
    gnbre=Adir(gabase,m.yrep+"*.*")
        For i=1 To gnbre
      Insert Into ycurs Values("",gabase(i,1),m.yrep,gabase(i,2),gabase(i,3),gabase(i,4),gabase(i,5))  &&&&filename,path,size,date last modified,time lm,File attributes
    Endfor
    thisform.ylab.caption=trans(reccount())+" files"
endi

If Reccount("ycurs")>0
	  dx=Dbf("ycurs")
	  dx=Left(dx, Rat(".",dx))+"cdx"
	 for i=1 to fcount()  					
		 text to m.myvar textmerge noshow			
		 Inde On <<field(i)>>  Tag <<field(i)>> Of (dx)  		
		 endtext
		 =Execscript(m.myvar)  &&inde on all grid columns
	endfor		
	 Set Order To 2 Ascending  &&filename
	  endi

    With Thisform.grid1
      .Anchor=15
      .RecordSource=""
      .RecordSource="ycurs"
      .RecordSourceType=1
      .GridLines=0
      .RowHeight=22
      .DeleteMark=.F.
      .RowHeight=20
      .readonly=.t.
      Locate
      .column1.Visible=.F.
      .setall("fontbold",.t.,"header")
      .setall("fontsize",10,"header")
    *  .Refresh
      For i=2 To .ColumnCount
		Bindevent(.Columns(i).header1,"mousedown",Thisform,"myg1")  && sorting asc/descending on any header(>=2)	
        bindevent(.columns(i).text1,"rightclick",thisform,"ycontext")   &&rightclick on  any grid column
        bindevent(.columns(i).text1,"click",thisform,"my0")   && click on any grid column
       endfor

    Sele ycurs
   Scan
      =yicon(Justext(filename),Recno())
      Repl Icon With m.yrep0+"icons\"+justext(filename)+".ico"
    Endscan

    With .column1
      .Width=20
      .header1.Caption=""
      Try
        .AddObject("img","image")
      Catch
      Endtry
      .CurrentControl="img"
      .Sparse=.F.
      With .img     &&32x32
        .Width=20
        .Height=22
        .Stretch=2
        .BackStyle=0
        .Visible=.T.
      Endwith
      .DynamicFontBold = 'ShowPicture(thisform.grid1.column1.img,m.yrep0+"icons\"+justext(filename)+".ico")'
      .Visible=.T.
    Endwith
    *Thisform.grid1.AutoFit  &&pb with dynamicBackcolor
    _screen.ellapsed=seconds()-_screen.t0
  .column1.width=20
  .column2.width=0.29*.width
  .column3.width=0.40*.width
  .column4.width=0.10*.width
  .column5.width=0.10*.width
  .column6.width=0.10*.width
  .setfocus
  locate
  .SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(239,250,207) , RGB(240,240,240))", "Column")
  .refresh
  endwith
  thisform.image1.visible=.f.
  thisform.grid1.visible=.t.
  thisform.mousepointer=0
  thisform.resize
   Endproc

procedure resize
with thisform.grid1
   try
  .column1.width=20
  .column2.width=0.29*.width
  .column3.width=0.33*.width
  .column4.width=0.10*.width
  .column5.width=0.10*.width
  .column6.width=0.10*.width
  *.refresh
  catch
  endtry
endwith

  Procedure ymenu.click	
  if thisform.grid1.visible=.f. or reccount()=0
  return .f.
  endi
DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR 1 OF raccourci PROMPT "1. execution Statistics"
DEFINE BAR 2 OF raccourci PROMPT "2. Gridlines(cycle 0-1-2-3)"
DEFINE BAR 3 OF raccourci PROMPT "3. Selected File properties"
DEFINE BAR 4 OF raccourci PROMPT "4. Grid fontsize"
DEFINE BAR 5 OF raccourci PROMPT "5. Search any word in grid"
DEFINE BAR 6 OF raccourci PROMPT "6. Export to html report"
DEFINE BAR 7 OF raccourci PROMPT "7. Summary Help"
DEFINE BAR 8 OF raccourci PROMPT "Grid Hightlight 0-1-2"

on selection bar 1 of raccourci _screen.activeform.ystats()
on selection bar 2 of raccourci _screen.activeform.ygridlines()
on selection bar 3 of raccourci  ydetailOf(addbs(allt(cPath))+allt(filename))
on selection bar 4 of raccourci _screen.activeform.yfsize()
on selection bar 5 of raccourci _screen.activeform.ygridsearch()
on selection bar 6 of raccourci _screen.activeform.yRhtml()
on selection bar 7 of raccourci  _screen.activeform.yHelp()
On selection Bar 8 of raccourci  _screen.activeform.yhighL()
ACTIVATE POPUP raccourci
endproc

procedure yhighL
with thisform.grid1
try
.highlightStyle=.highlightStyle+1
catch
.highlightStyle=0
endtry
wait window "hilightstyle="+trans(.highlightstyle)  timeout 1
endwith
endproc

PROCEDURE my0
KEYBOARD "{CTRL+A}"
thisform.ystat.caption=lower(allt(filename))+"  -  Record : ["+trans(recno())+"/"+trans(reccount())+ "]"
ENDPROC

procedure yhelp()
text to m.myvar pretext 7 noshow
In the previous post i attached  to the grid the icons of the associated application only.these groups many icons for all kind of controls.
In this post each file have its proper icon (for ex scx,prg,app,frx,h,vcx,....and so).
this is not ever done previously from any vfp code and its an absolutly a new method.
this code shows a directory files in a vfp grid as the windows ListView looks like (iconed)
the new (i dont see it anywhere before) is to make original icon beside the file in grid (there is some hints in news2news but with
 listView as windows explorer does).
All knows cannot position directly for each row anb image or icon in grid.Must rescue to dynamicBackcolor,dynamicForecolor...to place the icons in one gesture.
in the grid,any file extension file have the correspondant icon as windows explorer does exactly in its frames.
this code creates icons from file extension and shows it in first column.
it uses the API shGetFileInfo to retrieve for any file extension the hIcon handle.
then with gdiplusX can built real icon from its handle.make the system.app in source folder (to avoid dialog locate..).
all files icons are created and gathered in a temporarly folder "icons",destroyed at the end of application(releasing form).

select any folder  (simple search files or recursively in subfolders) and go.
Note: for background image internet must be connected.
credits to  http://www.news2news.com/vfp/?group=-1&function=1074  SHGetFileInfo API permit me to start with this project

*get any folder in dialog
*can check the recurse folder if the case (include subfolders)
*can fire the main menu for -statistics of the current main
                            -gridlines(cycle in 0-1-2-3)+set grid.Hilightsyle
                            -Selected files properties
                            -grid fontsize
                            -search/hilight  any word with ygsearch class in grid
                            -export to html report (with 5 beautified css styles)
*any row have a contextuel menu   -edit file
                                  -open selected folder
                                  -run file with associated application (shellexecute)
                                  -copy field,file properties,all row fields
*Elements shown in grid are: filename,folder,size (bytes),DateLastModified,RTimeLasModified,Attribures (as ADir() function  can provides).
*
there is a pure API method i complet it and publish in next post.
endtext
local oshell
oshell = Newobject('WScript.Shell')
oshell.Popup(m.myvar,0, ' Summary help', 0+32+4096)
oshell=null
endproc

PROCEDURE yRhtml
*try
sele ycurs
if reccount()=0
return .f.
endi
sele filename,cPath,xsize,dateLM,timeLM,xattr from ycurs into cursor ocurs
do (_genhtml) with (m.yrep0+'yreporthtml.html'),'ocurs',4
use in select("ocurs")
sele ycurs
inke(3)
declare integer BringWindowToTop in user32 integer HWND
local apie
apie=newObject("internetexplorer.application")
with apie
.navigate(m.yrep0+"yreporthtml.html")
.menubar=0
.toolbar=0
.statusbar=0
.width=1024
.height=600
bringwindowtotop(.hwnd)
inke(1)
rand(-1)
local m.nr
m.nr= INT(3*RAND()+1)
do case
case m.nr=1
.document.body.bgcolor=rgb(254,250,197)
case m.nr=2
.document.body.bgcolor=rgb(206,255,255)
case m.nr=3
.document.body.bgcolor=rgb(255,230,217)
endcase
.visible=.t.
endwith
endproc

procedure ystats()
sele ycurs
LOCAL m.xx,m.xunit
xunit=" bytes"
sum xsize to m.xx  &&bytes
do case

case between(m.xx,0,1024-1)
m.xunit="bytes"
m.xx=m.xx

case between(m.xx,1024,1024*1024-1)
xunit="Kbytes"
m.xx=m.xx/(1024)

case between(m.xx,1024*1024,1024*1024*1024)
xunit="Mbytes"
m.xx=m.xx/(1024*1024)

case m.xx>1024*1024*1024*1024
xunit="Gbytes"
m.xx=m.xx/(1024*1024*1024)

endcase
local m.myvar
text to m.myvar textmerge pretext 7  noshow
-Time ellapsed to search=<<trans(_screen.ellapsed,"99999")>> seconds
-records found         =<<reccount()>>
-Amount capacity of found files=<<m.xx>> <<m.xunit>>
endtext
messagebox(m.myvar,0+32+4096,"Statistics")
endproc

procedure ygridlines
try
thisform.grid1.gridlines=thisform.grid1.gridlines+1
catch
thisform.grid1.gridlines=0
endtry
endproc

procedure yfsize()
local m.x
m.x=int(val(inputbox("Fontsize to set","",trans(thisform.grid1.fontsize+1))) )
if m.x>=8
with thisform.grid1
for i=2 to .columncount
.columns(i).fontsize=m.x
endfor
.refresh
endwith
endi
endproc

procedure ygridsearch()
with thisform
try
.addObject("ygsearch","ygsearch")
catch
endtry
with .ygsearch
.left=thisform.ylab.left+thisform.ylab.width+50
.top=2
.visible=.t.
.text1.setfocus
endwith
endwith
endproc

procedure yremovesearch()
try
with thisform
.grid1.setall("dynamicbackcolor","","column")
.grid1.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(239,250,207) , RGB(240,240,240))", "Column")
*.grid1.refresh
.removeobject("ygsearch")
endwith
catch
endtry
endproc

PROCEDURE yedit
	 &&rightlick on file name in grid
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	if ! messagebox("Want to Edit :"+allt(loObject.value)+" ?",4+64)=6
	return.f.
	endi
	sele ycurs
	local m.xfilename
	m.xfilename=addbs(allt(cPath))+allt(filename)
	local m.ext
	m.ext=justext(filename)
	Do Case
		Case Inlist(ext,"prg","qpr","mpr","h  ")
		  Modi Comm (m.xfilename) Nowait
		Case Inlist(ext,"txt","log","lst","ini","   ")
		  Modi File (m.xfilename) Nowait
		Case Inlist(ext, "pjx","pjt")
		  Modi Proj (m.xfilename) Nowait
		Case Inlist(ext, "frx","frt","lbx","lbt")
		  Modi Repo (m.xfilename) Nowait
		Case Inlist(ext, "scx","sct")
		  Modi Form (m.xfilename) Nowait
		Case Inlist(ext, "mnx","mnt")
		  Modi Menu (m.xfilename) Nowait
		Case Inlist(ext, "qpr")
		  Modi Query (m.xfilename) Nowait
		Case Inlist(ext, "dbc","dct")
		  Modi Database (m.xfilename) Nowait
		Case Inlist(ext, "vcx","vct")
		  Do (_Browser) With (m.xfilename)
		Other
		try  && if access file not permitted (for ex fxp file in use)
		  Modi File (m.xfilename) Nowait   &&edit as text only
		catch
		wait window "cannot edit the file...no access !" timeout 1
		endtry
	  Endcase
ENDPROC

PROCEDURE myg1	
	Lparameters nButton, nShift, nXCoord, nYCoord
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	Local N
	N=Int(Val(Substr(loObject.Parent.Name,7)))
	Thisform.grid_reorder(N)
	Nodefault
ENDPROC

PROCEDURE grid_reorder
	* grid_reorder
	Lparameters ColNo
	Local _sele
	_sele=Sele()
	If Used("ycurs")
	  Sele ycurs
	  If Tagno()=ColNo And !"DESCE"$Set("order")
		Set Order To ColNo Descending
	  Else
		Set Order To ColNo Ascending
	  Endif
	  This.grid1.Refresh
	Endif
	Sele (_sele)
ENDPROC

	procedure ycontext
 &&rightlick on file name in grid
	*--- aevent create an array laEvents
	Aevents( myArray, 0)
	*--- reference the calling object
	loObject = myArray[1]
	DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR 1 OF raccourci PROMPT "Edit selected file"
DEFINE BAR 2 OF raccourci PROMPT "open selected folder"
DEFINE BAR 3 OF raccourci PROMPT "Run with associated app"
DEFINE BAR 4 OF raccourci PROMPT "Copy"
DEFINE BAR 5 OF raccourci PROMPT "properties"
DEFINE BAR 6 OF raccourci PROMPT "Record Fields"

On selection Bar 1 of raccourci  _screen.activeform.yedit()
On selection Bar 2 of raccourci  _screen.activeform.yopenfolder()
On selection Bar 3 of raccourci  _screen.activeform.yopenAss()
On selection Bar 4 of raccourci  _screen.activeform.ycopy()
On selection Bar 5 of raccourci  ydetailOf(addbs(allt(cPath))+allt(filename))
On selection Bar 6 of raccourci  _screen.activeform.yprop()
ACTIVATE POPUP raccourci
endproc

procedure ycopy
with thisform.grid1
local m.ox
m.ox=.columns(.activecolumn).text1.value
endwith
 _cliptext=trans(m.ox)
endproc

Procedure yprop
sele ycurs
local m.x
m.x="Properties "+chr(13)+chr(13)
for i=2 to fcount()
m.x=m.x+field(i)+" :"+allt(trans(eval(field(i))))+chr(13)
endfor
messagebox(m.x,0+32+4096,"Record properties")
endproc

procedure yopenAss()
if !used("ycurs")
	return .f.
	endi
	if ! messagebox("Open this file with associated app?",4+64)=6
	return .f.
	endi
	local m.xfilename
	m.xfilename=addbs(allt(cPath))+allt(filename)
	result = ShellExecute(0, "open",m.xfilename,"","",1)
	if result<=32
	messagebox("An error was occured!",4+4096,'Error',1300)
	endi
endproc

procedure yopenfolder()
local m.oo
m.oo= allt(ycurs.cPath)
if directory(m.oo)
run/n explorer &oo
endi
endproc

PROCEDURE image1.Init
	local  m.myvar0
	text to m.myvar0 noshow
	R0lGODlhIAAgALMAAP///7Ozs/v7+9bW1uHh4fLy8rq6uoGBgTQ0NAEBARsbG8TExJeXl/39/VRUVAAAACH/C05FVFNDQVBFMi4wAwEAAAAh+QQFBQAAACwAAAAAIAAgAAAE5xDISSlLrOrNp0pKNRCdFhxVolJLEJQUoSgOpSYT4RowNSsvyW1icA16k8MMMRkCBjskBTFDAZyuAEkqCfxIQ2hgQRFvAQEEIjNxVDW6XNE4YagRjuBCwe60smQUDnd4Rz1ZAQZnFAGDd0hihh12CEE9kjAEVlycXIg7BAsMB6SlnJ87paqbSKiKoqusnbMdmDC2tXQlkUhziYtyWTxIfy6BE8WJt5YEvpJivxNaGmLHT0VnOgGYf0dZXS7APdpB309RnHOG5gDqXGLDaC457D1zZ/V/nmOM82XiHQjYKhKP1oZmADdEAAAh+QQFBQAAACwAAAAAGAAXAAAEchDISasKNeuJFKoHs4mUYlJIkmjIV54Soypsa0wmLSnqoTEtBw52mG0AjhYpBxioEqRNy8V0qFzNw+GGwlJki4lBqx1IBgjMkRIghwjrzcDti2/Gh7D9qN774wQGAYOEfwCChIV/gYmDho+QkZKTR3p7EQAh+QQFBQAAACwBAAAAHQAOAAAEchDISWdANesNHHJZwE2DUSEo5SjKKB2HOKGYFLD1CB/DnEoIlkti2PlyuKGEATMBaAACSyGbEDYD4zN1YIEmh0SCQQgYehNmTNNaKsQJXmBuuEYPi9ECAU/UFnNzeUp9VBQEBoFOLmFxWHNoQw6RWEocEQAh+QQFBQAAACwHAAAAGQARAAAEaRDICdZZNOvNDsvfBhBDdpwZgohBgE3nQaki0AYEjEqOGmqDlkEnAzBUjhrA0CoBYhLVSkm4SaAAWkahCFAWTU0A4RxzFWJnzXFWJJWb9pTihRu5dvghl+/7NQmBggo/fYKHCX8AiAmEEQAh+QQFBQAAACwOAAAAEgAYAAAEZXCwAaq9ODAMDOUAI17McYDhWA3mCYpb1RooXBktmsbt944BU6zCQCBQiwPB4jAihiCK86irTB20qvWp7Xq/FYV4TNWNz4oqWoEIgL0HX/eQSLi69boCikTkE2VVDAp5d1p0CW4RACH5BAUFAAAALA4AAAASAB4AAASAkBgCqr3YBIMXvkEIMsxXhcFFpiZqBaTXisBClibgAnd+ijYGq2I4HAamwXBgNHJ8BEbzgPNNjz7LwpnFDLvgLGJMdnw/5DRCrHaE3xbKm6FQwOt1xDnpwCvcJgcJMgEIeCYOCQlrF4YmBIoJVV2CCXZvCooHbwGRcAiKcmFUJhEAIfkEBQUAAAAsDwABABEAHwAABHsQyAkGoRivELInnOFlBjeM1BCiFBdcbMUtKQdTN0CUJru5NJQrYMh5VIFTTKJcOj2HqJQRhEqvqGuU+uw6AwgEwxkOO55lxIihoDjKY8pBoThPxmpAYi+hKzoeewkTdHkZghMIdCOIhIuHfBMOjxiNLR4KCW1ODAlxSxEAIfkEBQUAAAAsCAAOABgAEgAABGwQyEkrCDgbYvvMoOF5ILaNaIoGKroch9hacD3MFMHUBzMHiBtgwJMBFolDB4GoGGBCACKRcAAUWAmzOWJQExysQsJgWj0KqvKalTiYPhp1LBFTtp10Is6mT5gdVFx1bRN8FTsVCAqDOB9+KhEAIfkEBQUAAAAsAgASAB0ADgAABHgQyEmrBePS4bQdQZBdR5IcHmWEgUFQgWKaKbWwwSIhc4LonsXhBSCsQoOSScGQDJiWwOHQnAxWBIYJNXEoFCiEWDI9jCzESey7GwMM5doEwW4jJoypQQ743u1WcTV0CgFzbhJ5XClfHYd/EwZnHoYVDgiOfHKQNREAIfkEBQUAAAAsAAAPABkAEQAABGeQqUQruDjrW3vaYCZ5X2ie6EkcKaooTAsi7ytnTq046BBsNcTvItz4AotMwKZBIC6H6CVAJaCcT0CUBTgaTg5nTCu9GKiDEMPJg5YBBOpwlnVzLwtqyKnZagZWahoMB2M3GgsHSRsRACH5BAUFAAAALAEACAARABgAAARcMKR0gL34npkUyyCAcAmyhBijkGi2UW02VHFt33iu7yiDIDaD4/erEYGDlu/nuBAOJ9Dvc2EcDgFAYIuaXS3bbOh6MIC5IAP5Eh5fk2exC4tpgwZyiyFgvhEMBBEAIfkEBQUAAAAsAAACAA4AHQAABHMQyAnYoViSlFDGXBJ808Ep5KRwV8qEg+pRCOeoioKMwJK0Ekcu54h9AoghKgXIMZgAApQZcCCu2Ax2O6NUud2pmJcyHA4L0uDM/ljYDCnGfGakJQE5YH0wUBYBAUYfBIFkHwaBgxkDgX5lgXpHAXcpBIsRADs=
	endtext
	this.pictureval=strconv(m.myvar0,14)  &&animated gif
	this.visible=.f.
ENDPROC
Enddefine
*-- EndDefine: ygrid_icons

Function yicon
  Lparameters ext,rec
  #Define SHGFI_ICON 0x000000100
  #Define SHGFI_TYPENAME 0x000000400
  #Define SHGFI_USEFILEATTRIBUTES 0x000000010
  #Define FILE_ATTRIBUTE_NORMAL 0x00000080

  *!*typedef struct _SHFILEINFO {
  *!*        HICON hIcon;
  *!*        int iIcon;
  *!*        DWORD dwAttributes;
  *!*        TCHAR szDisplayName[MAX_PATH];
  *!*        TCHAR szTypeName[80];
  *!*} SHFILEINFO;

  Local cext, nBufsize, cBuffer, nFlags,;
    nResult, hIcon
  cext = "."+ext
  nBufsize=1024
  cBuffer = Replicate(Chr(0), nBufsize)
  nFlags = Bitor(SHGFI_ICON,;
    SHGFI_TYPENAME, SHGFI_USEFILEATTRIBUTES)
  nResult = SHGetFileInfo(cext, FILE_ATTRIBUTE_NORMAL,;
    @cBuffer, nBufsize, nFlags)
  hIcon = buf2dword(Substr(cBuffer, 1, 4))

  If hIcon <> 0
    =iconfromhIcon(hIcon,ext)  &&build  icon file from handle hIcon.
   = DestroyIcon(hIcon)  &&clean mandatory (for freeing the icon handle refrence)
 Endif
Endfunc

Function buf2dword(lcBuffer)
  Return Asc(Substr(lcBuffer, 1,1)) + ;
    BitLShift(Asc(Substr(lcBuffer, 2,1)),  8) +;
    BitLShift(Asc(Substr(lcBuffer, 3,1)), 16) +;
    BitLShift(Asc(Substr(lcBuffer, 4,1)), 24)
Endfunc

Function iconfromhIcon
  Lparameters hIcon,ext
  With _Screen.System.drawing
    * create icon object
    Local loicon As xfcicon
    loicon = .Icon.fromhandle(hIcon)
    Local m.lcdest
    m.lcdest=m.yrep0+"icons\"+allt(ext)+".ico"
    loicon.Save(m.lcdest, .T.)  && high quality icons by  setting the tlquality flag to .t.
  Endwith
Endfunc

Procedure showPicture  &&for dynamicfontbold /filling icons
  Lparameters toImage, tcImage
  toImage.Picture = tcImage
Endproc

Function RecurseFolder( lcDir)
Local i,N, laFiles[1]
*m.nrep=m.nrep+1
N = Adir( laFiles, lcDir + "*.*", "shd" )
For i = 1 To N
	If ( Left( laFiles[i,1], 1 ) != '.' )
		If ( "D" $ laFiles[i,5] )
			Try  &&pb error for big folders...to avoid error :trop de do ...."
				RecurseFolder( lcDir + laFiles[i,1] + "\" )
			Catch
			Endtry
		Else
			Insert Into ycurs Values( "",laFiles[i,1],lcDir,laFiles[i,2], laFiles[i,3] ,laFiles[i,4],laFiles[i,5])  &&filename,path,size,date last modified,time lm,File attributes
		Endif
	Endif
Endfor
endfunc

Function ydetailOf()
Lparameters lcfilename
if pcount()<>1
return .f.
endi
Local m.x
m.x="detail of "+lcfilename+Chr(13)+Chr(13)
Dimension arrHeaders(35)
Local objShell,oBjFolder As Object
objShell = Createobject("Shell.Application")
oBjFolder = objShell.Namespace(Justpath(lcfilename))
For i = 1 To 35
arrHeaders(i) = oBjFolder.GetDetailsOf(oBjFolder.Items, i)
Next
For Each strFileName In oBjFolder.Items
If Lower(strFileName.Name)=Juststem(Allt(Lower(lcfilename)))
  For i = 1 To 35
	If !Empty(oBjFolder.GetDetailsOf(strFileName, i))
	  m.x=m.x+Trans(i)+"   "+ arrHeaders(i) +"   "+": " + oBjFolder.GetDetailsOf(strFileName, i)+Chr(13)
	Endi
  Next
Endi
Next
oBjFolder=Null
objShell=Null
messagebox(m.x,0+32+4096,"File properties")
*Return m.x
Endfunc

define class ygsearch as container
width=400
height=24
backstyle=0
borderwidth=0
name="ygsearch"

Add Object text1 As TextBox With ;
FontBold = .T., ;
Height = 25, ;
Left = 16, ;
Top = 0, ;
Width = 229, ;
ForeColor = Rgb(128,0,64), ;
Name = "Text1"

Add Object yclose As Label With ;
AutoSize = .T., ;
BackStyle = 0, ;
Caption = "X", ;
autosize=.t.,;
Left = 2, ;
Top = 3, ;
ForeColor = Rgb(128,0,64), ;
mousepointer=15,;
fontsize=12,;
borderstyle=0,;
Name = "yclose"

Add Object label1 As Label With ;
AutoSize = .T., ;
BackStyle = 0, ;
Caption = "", ;
Height = 17, ;
Left = 264, ;
Top = 3, ;
Width = 2, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label1"

Procedure yclose.click
thisform.yremoveSearch()
endproc

Procedure text1.LostFocus
This.parent.label1.Caption=""
Endproc

Procedure text1.InteractiveChange
sele ycurs
  Local m.tot,m.n
m.n=0
m.tot=0
For Each oCol As Column In Thisform.grid1.Columns FoxObject
  If Type(oCol.ControlSource)="C"
	Count For  Upper(Alltrim(m.this.Value)) $ Eval("UPPER(ALLTRIM("+oCol.ControlSource+"))")   To m.n
	m.tot=m.tot+m.n
  Endi
Next
This.parent.label1.Caption=Trans(m.tot) +" occurences found  "

For Each oCol As Column In Thisform.grid1.Columns FoxObject
if  lower(oCol.name)=="column1"
loop
endi
  If Type(oCol.ControlSource)="C"
   oCol.DynamicBackColor="IIF(upper(allt(thisform.ygsearch.text1.value)) $ UPPER(ALLTRIM("  +oCol.ControlSource   +")),rgb(173,255,47),RGB(255,255,255) )"
  Else
	oCol.DynamicBackColor=""
  Endif
Next
Locate
Thisform.grid1.Refresh
Endproc
Enddefine
*-- EndDefine: ygSearch


A vfp grid filer with files icons  attached as ListView
A vfp grid filer with files icons  attached as ListView
A vfp grid filer with files icons  attached as ListView
A vfp grid filer with files icons  attached as ListView
A vfp grid filer with files icons  attached as ListView

Click on code to select [then copy] -click outside to deselect


*2* created on friday 19 of january 2018
*this code retrieves all icons present on a PC  with their associated applications icons and real files icons
*the DOS command ASSOC retrieves all extensions used in the PC.we build the assoc.txt (.extension,filetype) and append in  a vfp cursor
*the extensions are in the registry in HKEY_CLASSES_ROOT(class: "."+extension).can read these key with shell and return the associated application with a specific used icon (index).
*with this can build the first grid column (column1.dynamicfontbold can populate the column1 icon pictures in one gsture).
*for the real extension icon can use shGetFileInfo api as code *1* above and GdiplusX to  retrieve the real icon (column2 populated with grid.column2.dynamicFontBold)
*if no icon found can insert any icon as substitute
*if no associated app of course there is no asicon (substitued).

Clea All
Close Data All
Set Safe Off

Do ydeclare  &&load Apis used

Do Locfile("system.app")  &&put system.app in source folder to be quiet.

Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
If Directory(m.yrep+"iconsA")  &&associated applications icons
  Erase (m.yrep+"iconsA\*.*")
Else
  Md (m.yrep+"iconsA")
Endi

If Directory(m.yrep+"icons0")  &&real file  icons
  Erase (m.yrep+"icons0\*.*")
Else
  Md (m.yrep+"icons0")
Endi

Local m.x     &&DOS command ASSOC can retrieve all extensions used on a PC,pathered on assoc.txt file
TEXT to m.x noshow
 assoc > assoc.txt
ENDTEXT
Strtofile(m.x,"ybat.bat")        &&build a bat file to execute with shellexecute Api.

=shellexecute(0,"open","ybat.bat","","",0)   &&cmd.exe hidden
Inke(3)
If File("assoc.txt")   &&cut "=" in the txt file
  m.y=Filetostr("assoc.txt")
  m.y=Strtran(m.y,"="," ")
  Strtofile(m.y,"assoc.txt")

  Crea Cursor ycurs (xext c(5),xassoc c(40),IconLocation c(100),xicon c(80))
  Append From assoc.txt Sdf

  Local oshell
  oshell = Createobject("WScript.Shell")
  Scan
    Try
      m.lcClass = oshell.RegRead("HKEY_CLASSES_ROOT\"+Allt(xext)+"\")
      m.lcIconLocation = oshell.RegRead("HKEY_CLASSES_ROOT\" + m.lcClass + "\DefaultIcon\")
      Repl IconLocation With  m.lcIconLocation    &&associated app+default icon used separated by ","

      m.lcfile =Getwordnum(m.lcIconLocation,1,",")
      m.lnIndex=Getwordnum(m.lcIconLocation,2,",")
      m.lcdest=m.yrep+"iconsA\"+Allt(Justext(xext))+".ico"
      =IconExtract(m.lcfile, m.lcdest, m.lnIndex)
    Catch
      m.lcdest=m.yrep+"iconsA\"+Justext(xext)+".ico"
      m.lcfile="c:\windows\system32\shell32.dll"
      IconExtract(m.lcfile, m.lcdest, 164)
    Endtry
  Endscan

  Scan
    Repl xicon With m.yrep+"icons0\"+Justext(xext)+".ico"
    =yicon(Justext(xext))
  Endscan
Endi
oshell=Null


Create Cursor zcurs(ASicon c(80),xicon c(80),ext c(5),xassoc c(40),IconLocation c(100))
Sele ycurs
Scan
  Insert Into zcurs Values("",xicon,Justext(ycurs.xext),ycurs.xassoc,ycurs.IconLocation)
Endscan
Use In Select("ycurs")

Sele zcurs
Scan
  If File(m.yrep+"iconsA\"+Allt(ext)+".ico")
    Repl ASicon With m.yrep+"iconsA\"+Allt(ext)+".ico"
  Else
    Repl ASicon With Home(1)+"graphics\icons\misc\misc15.ico"  &&substitute
  Endi

  If File(m.yrep+"icons0\"+Allt(ext)+".ico")
    Repl xicon With m.yrep+"icons0\"+Allt(ext)+".ico"
  Else
    Repl xicon With Home(1)+"graphics\icons\misc\misc15.ico"   &&substitute
  Endi

Endscan
*brow
Wait Clea


*show on a form
Publi oform
oform=Newobject("yassoc")
oform.Show
Read Events
Retu

Define Class yassoc As Form
  ShowWindow=2
  BorderStyle=3
  Width=800
  Height=600
  AutoCenter=.T.
  caption="Associated files icons and real files icons"
  Name="form1"

  Procedure Init
    With Thisform
      .AddObject("ystat","label")
      With .ystat
        .AutoSize=.T.
        .FontSize=10
        .fontname="courier new"
        .BackStyle=0
        .Caption=""
        .ForeColor=255
        .Left=30
        .Top=600-20
        .anchor=768
        .Visible=.T.
      Endwith

      .AddObject("grid1","grid")
      With .grid1
        .RecordSource="zcurs"
        .RecordSourceType=1
        .RowHeight=25
        .Width=780
        .Height=560
        .Anchor=15
        .DeleteMark=.F.
        .GridLines=0
        .Left=0
        .Top=0
        .ReadOnly=.T.

        With .column1
          .Width=40
          .AddObject("img",'image')
          .CurrentControl='img'
          .Sparse=.F.
          With .img
            .Stretch=1
            .Width=25
            .Height=25
            .Picture=""
            .Visible=.T.
          Endwith
          .DynamicFontBold = 'ShowPicture(thisform.grid1.column1.img,asicon)'  &&fill associated icon
        Endwith

        With .column2
          .Width=40
          .AddObject("img1",'image')
          .CurrentControl='img1'
          .Sparse=.F.
          With .img1
            .Stretch=1
            .Width=25
            .Height=25
            .Visible=.T.
          Endwith
          .DynamicFontBold = 'ShowPicture(thisform.grid1.column2.img1,xicon)'  &&fill real icons
        Endwith
        .AutoFit()
        For i=3 To .ColumnCount
          Bindevent(.Columns(i).text1,"mousedown",Thisform,"my")
        Endfor
        .Refresh
        Locate
        .Visible=.T.
      Endwith
      .AutoCenter=.T.
    Endwith

  Procedure my
    Lparameters nButton, nShift, nXCoord, nYCoord
    *--- aevent create an array laEvents
    Aevents( myArray, 0)
    *--- reference the calling object
    loObject = myArray[1]
    Thisform.ystat.Caption=" Record "+Trans(Recno())+"/"+Trans(Reccount())+"   class: ."+allt(ext)
  Endproc

  Procedure Destroy
    Clea Resources
    Try
      Erase m.yrep+"iconsA\*.*"
      Rd m.yrep+"iconsA"
      Erase m.yrep+"icons0\*.*"
      Rd m.yrep+"icons0"
    Catch
    Endtry

    Clear Dlls 'ExtractIcon', 'OleCreatePictureIndirect', 'DestroyIcon'
    m.yrep=Null
    Release m.yrep
    oform=Null
    Release oform
    Clea Events
  Endproc

Enddefine
*EndDefine yassoc

Procedure ydeclare
  Declare Integer SHGetFileInfo In shell32;
    STRING pszPath,;
    LONG dwFileAttributes,;
    STRING @psfi,;
    LONG cbFileInfo,;
    LONG uFlags
  Declare SHORT DestroyIcon In user32 Integer hIcon
  &&shellexecute
  Declare Integer ShellExecute In SHELL32.Dll Integer nWinHandle,;
    STRING cOperation,;
    STRING cFileName,;
    STRING cParameters,;
    STRING cDirectory,;
    INTEGER nShowWindow
  Declare Integer ExtractIcon In shell32 Integer, String, Integer
  Declare Long OleCreatePictureIndirect In oleaut32 String @, String @, Long, Object @
  Declare SHORT DestroyIcon In user32 Integer
Endproc

Procedure IconExtract
  Lparameters tcSourceFile As String, tcTargetFile As String, tnIconIndex As Integer
  Local lnIconHandle As Integer, loIconReference As Object
  tnIconIndex = Iif(Vartype(tnIconIndex) = 'N', tnIconIndex, 0)
  lnIconHandle = ExtractIcon(0, tcSourceFile, tnIconIndex)
  If lnIconHandle # 0
    tcStructure = Long2String(16) + Long2String(3) + Long2String(lnIconHandle) + Long2String(0)
    tcIdentifier = Replicate(Chr(0), 8) + Chr(0xC0)+ Replicate(Chr(0), 6) + Chr(0x46)
    loIconReference = 0
    OleCreatePictureIndirect(@tcStructure, @tcIdentifier, 1, @loIconReference)
    If Vartype(loIconReference) = 'O'
      If SavePicture(loIconReference, tcTargetFile)  =.T.
        *icon successfull created
      Endif
    Else
      Messagebox('OleCreatePictureIndirect() error')
    Endif
    DestroyIcon(lnIconHandle)
  Else
    Wait Window 'ExtractIcon() error'   Nowait
  Endif

  Return
Endproc

Procedure showPicture  &&for dynamicfontbold /filling icons
  Lparameters toImage, tcImage
  toImage.Picture = tcImage
Endproc

Function yicon   &&creating real icons
  Lparameters ext
  #Define SHGFI_ICON 0x000000100
  #Define SHGFI_TYPENAME 0x000000400
  #Define SHGFI_USEFILEATTRIBUTES 0x000000010
  #Define FILE_ATTRIBUTE_NORMAL 0x00000080

  *!*typedef struct _SHFILEINFO {
  *!*        HICON hIcon;
  *!*        int iIcon;
  *!*        DWORD dwAttributes;
  *!*        TCHAR szDisplayName[MAX_PATH];
  *!*        TCHAR szTypeName[80];
  *!*} SHFILEINFO;

  Local cext, nBufsize, cBuffer, nFlags,;
    nResult, hIcon
  cext = "."+ext
  nBufsize=1024
  cBuffer = Replicate(Chr(0), nBufsize)
  nFlags = Bitor(SHGFI_ICON,;
    SHGFI_TYPENAME, SHGFI_USEFILEATTRIBUTES)
  nResult = SHGetFileInfo(cext, FILE_ATTRIBUTE_NORMAL,;
    @cBuffer, nBufsize, nFlags)
  hIcon = buf2dword(Substr(cBuffer, 1, 4))

  If hIcon <> 0
    =iconfromhIcon(hIcon,ext)  &&build  icon file from handle hIcon.
    = DestroyIcon(hIcon)        &&clean mandatory (for freeing the icon handle refrence)
  Endif
Endfunc

Function buf2dword(lcBuffer)
  Return Asc(Substr(lcBuffer, 1,1)) + ;
    BitLShift(Asc(Substr(lcBuffer, 2,1)),  8) +;
    BitLShift(Asc(Substr(lcBuffer, 3,1)), 16) +;
    BitLShift(Asc(Substr(lcBuffer, 4,1)), 24)
Endfunc

Function iconfromhIcon
  Lparameters hIcon,ext
  With _Screen.System.drawing
    * create icon object
    Local loicon As xfcicon
    loicon = .Icon.fromhandle(hIcon)
    Local m.lcdest
    m.lcdest=m.yrep+"icons0\"+Allt(ext)+".ico"
    loicon.Save(m.lcdest, .T.)  && high quality icons by  setting the tlquality flag to .t.
  Endwith
Endfunc

Function Long2String
  Lparameters tnLong
  tnLong = Int(tnLong)
  Return Chr(Bitand(tnLong, 255)) + ;
    CHR(Bitand(Bitrshift(tnLong, 8), 255)) + ;
    CHR(Bitand(Bitrshift(tnLong, 16), 255)) + ;
    CHR(Bitand(Bitrshift(tnLong, 24), 255))
Endfunc


run a command prompt (cmd.exe) and type assoc /? to see te assoc command help

run a command prompt (cmd.exe) and type assoc /? to see te assoc command help

Click on code to select [then copy] -click outside to deselect

 

*3* created on friday 17 of january 2018
*FTYPE:DOS command Displays or modifies file types used in file name extension associations.
*Used without parameters, ftype displays all the file types that have open command strings defined in registry.


set safe off
&&shellexecute
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
Local m.x
TEXT to m.x noshow
 ftype > ftype.txt
ENDTEXT
Strtofile(m.x,"ybat.bat")        &&build a bat file to execute with shellexecute Api.

=shellexecute(0,"open","ybat.bat","","",0)   &&cmd.exe hidden
Inke(3)
If !File("ftype.txt")   
  Return .F.
Endi
*run/n notepad ftype.txt

*create a cursor
Set Memow To 8192
local m.myvar,m.x1,m.x2
m.myvar=Filetostr("ftype.txt")
Crea Cursor ycurs (xftype c(50),xcommand c(150))
For i=1 To Memlines(m.myvar)
  x1=Getwordnum(Mline(m.myvar,i),1,"=")  && "=" as separator here
  x2=Getwordnum(Mline(m.myvar,i),2,"=")
  Insert Into ycurs Values( m.x1,m.x2  )
Endfor
locate
Brow Title "file types that have open command strings defined." name ybrow nowait

with ybrow
.gridlines=0
.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(239,250,207) , RGB(240,240,240))", "Column")
.refresh
endwith

wait "close window to continue"

Brow  Title "file types that have open command strings defined."  For  "Visual.FoxPro" $  xftype name ybrow1 nowait
with ybrow1
.gridlines=0
.SetAll("DynamicBackColor","IIF(MOD(RECNO( ), 2)=0, RGB(239,250,207) , RGB(240,240,240))", "Column")
.refresh
endwith

erase ftype.txt


run a command prompt (cmd.exe) and type ftype /? to see te ftype command  help

run a command prompt (cmd.exe) and type ftype /? to see te ftype command help


                     

Yousfi Benameur


Important:All Codes above are tested on VFP9SP2 & windows 10 pro 64 bits version 1709(fall creator) & IE11 emulation.

To be informed of the latest articles, subscribe:
Comment on this post