An iconed grid as Listview with pure APIs
In the 2th previous post (searchmyFiles) 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 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. *here gdipluX is not recquired at all.the code uses exclusively APis to create Icons from handle hIcon. 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 *Note i guess the shGetFileInfo API was built with the windows listview (as explorer interface for ex.) *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,Attributes (as ADir() function can provides). * [Post 256]
Click on code to select [then copy] -click outside to deselect
*1* created on Saturday 20 of january 2018
*this code shows a directory files in a vfp grid as the windows ListView does (iconed) as a filer.
*the goal is to make original icon beside each file in grid .
*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.
*instead of previous post using GdiplusX to create physical icons,this uses exclusively Apis to do the job.
*select any folder and go.
*for background image internet must be connected.
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
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
Declare Long OleCreatePictureIndirect In "oleaut32.dll" String @ , String @ , Long , Object @
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 local 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) &&index 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")
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 2th 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.
*here gdipluX is not recquired at all.the code uses exclusively APis to create Icons from handle hIcon.
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).
*
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")
.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 rotating gif for waiting...
this.visible=.f.
ENDPROC
Enddefine
*-- EndDefine: ygrid_icons
Function yicon &&this dont go to gdiplusX but use Apis only to generate icons form hIcon.it uses APis exclusively.
Lparameters cExtension,rec
Local lcFullPath, llSuccess
m.lcFullPath = m.yrep0+"icons\"+Lower( Alltrim( cExtension ) ) + ".ico" &&gather icons in icons folder to run grid dynamicFontbold to fill icons column.
If Pcount() = 0
Return .F.
Endif
IF FILE(m.lcFullPath)
RETURN .T.
ENDIF
Local lhIcon
m.lhIcon = getIconByExtension ( m.cExtension )
If m.lhIcon = 0
Return .F.
Endif
m.llSuccess = savePictureOnDisk( m.lhIcon,m.lcFullPath )
= destroyIcon( m.lhIcon )
Return m.llSuccess
Procedure getIconByExtension ( cExtension )
#Define SHGFI_ICON 0x000000100
#Define SHGFI_TYPENAME 0x000000400
#Define SHGFI_USEFILEATTRIBUTES 0x000000010
#Define FILE_ATTRIBUTE_NORMAL 0x00000080
Local lcFilename, lnBufsize, lcBuffer, lnFlags, lnResult, lhIcon
m.lcFilename = Iif( At( ".", m.cExtension, 1 ) <> 1, "." + Alltrim( m.cExtension ), Alltrim( m.cExtension ) )
m.lnBufsize = 1024
m.lcBuffer = Replicate( Chr(0), m.lnBufsize )
m.lnFlags = Bitor( SHGFI_ICON, SHGFI_TYPENAME, SHGFI_USEFILEATTRIBUTES )
m.lnResult = SHGetFileInfo( m.lcFilename, FILE_ATTRIBUTE_NORMAL, @lcBuffer, m.lnBufsize, m.lnFlags )
m.lhIcon = buf2dword( Substr( m.lcBuffer, 1, 4 ) )
Return m.lhIcon
Endproc
Procedure savePictureOnDisk ( hIcon, cFullPath )
Local lcStructure, lcIdentifier, loIconReference, llSuccess
m.lcStructure = Long2String(16) + Long2String(3) + Long2String( m.hIcon ) + Long2String(0)
m.lcIdentifier = Replicate(Chr(0), 8) + Chr(0xC0)+ Replicate(Chr(0), 6) + Chr(0x46)
m.loIconReference = 0
= OleCreatePictureIndirect( @lcStructure, @lcIdentifier, 1, @loIconReference )
If Vartype( m.loIconReference ) = "O"
m.llSuccess = SavePicture( m.loIconReference, m.cFullPath )
Endif
Return m.llSuccess
Endproc
Procedure destroyIcon ( hIcon )
If m.hIcon <> 0
= destroyIcon( m.hIcon )
Endif
Endproc
Function buf2dword( cBuffer )
Return Asc( Substr( m.cBuffer, 1, 1 ) ) + ;
BitLShift( Asc( Substr( m.cBuffer, 2, 1 ) ), 8 ) + ;
BitLShift( Asc( Substr( m.cBuffer, 3, 1 ) ), 16 ) + ;
BitLShift( Asc( Substr( m.cBuffer, 4, 1 ) ), 24 )
Endfunc
Function Long2String ( nLong )
m.nLong = Int( m.nLong )
Return Chr( Bitand( m.nLong, 255)) + ;
CHR( Bitand( Bitrshift( m.nLong, 8 ), 255 ) ) + ;
CHR( Bitand( Bitrshift( m.nLong, 16 ), 255 ) ) + ;
CHR( Bitand( Bitrshift( m.nLong, 24 ), 255 ) )
Endfunc
Procedure showPicture &&for dynamicfontbold /filling grid column icons
Lparameters toImage, tcImage
toImage.Picture = tcImage
Endproc
Function RecurseFolder( lcDir)
Local i,N, laFiles[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
Reference to the shGetFileInfo api can introduce other constants to have 16x16 icons (small_icons).here all are 32x32 size.
Click on code to select [then copy] -click outside to deselect
*2*
*icons above are normal icons (32x32 size)
*for having small icons can use this code instead the same procedure above
Procedure getIconByExtension ( cExtension )
#Define SHGFI_ICON 0x000000100
#define SHGFI_SMALLICON 0x000000001
#define SHGFI_SYSICONINDEX 0x000004000
#Define SHGFI_TYPENAME 0x000000400
#Define SHGFI_USEFILEATTRIBUTES 0x000000010
#Define FILE_ATTRIBUTE_NORMAL 0x00000080
Local lcFilename, lnBufsize, lcBuffer, lnFlags, lnResult, lhIcon
m.lcFilename = Iif( At( ".", m.cExtension, 1 ) <> 1, "." + Alltrim( m.cExtension ), Alltrim( m.cExtension ) )
m.lnBufsize = 1024
m.lcBuffer = Replicate( Chr(0), m.lnBufsize )
m.lnFlags = Bitor(SHGFI_USEFILEATTRIBUTES,SHGFI_ICON,SHGFI_SMALLICON)
m.lnResult = SHGetFileInfo( m.lcFilename, FILE_ATTRIBUTE_NORMAL, @lcBuffer, m.lnBufsize, m.lnFlags )
m.lhIcon = buf2dword( Substr( m.lcBuffer, 1, 4 ) )
Return m.lhIcon
Endproc
*it works and produce 16x16 icons but on grid the background is black (even if img backstyle=0).....to solve
*i have doubt on savepicture vfp function to apply to icon... it export image with a background black...
this needs to change the black color to white transparent (yet gdiplusX or other APIs...).Let we Stay with above solution with 32x32 and background transparent.
some relative links in/out this blog
A vfp grid filer with icons attached as listviewextract icons from exe, apps or dlls part2
extract icons from exe ,dlls and draw directly on vfp form
Search files with searchMyFiles tool
Beautify your tables with css
VFP grid cosmetics part 2
VFP grid cosmetcis part 1
Genhtml
shGetFileinfo API
SHGetFileInfo function
|
|
Yousfi Benameur |
Important:All Codes above are tested on VFP9SP2 & windows 10 pro 64 bits version 1709(fall creator) & IE11 emulation.