A vfp grid filer with files icons attached as ListView
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
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
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
some relative links in/out this blog
Search files with searchMyFiles toolBeautify your tables with css
VFP grid cosmetics part 2
VFP grid cosmetcis part 1
Genhtml
shGetFileinfo API
|
|
Yousfi Benameur |
Important:All Codes above are tested on VFP9SP2 & windows 10 pro 64 bits version 1709(fall creator) & IE11 emulation.