Images viewer with the IE vfp browser
*tested successfully on windows8.1
*Warning: on windows10 the code returns an error at this line (first time tested on september 8 2015)
[Thisform.obrowser.Document.script.SetVFPObject(Thisform)]
windows10 seems having problem with vbscript!
see this link:https://msdn.microsoft.com/library/dn384057%28v=vs.85%29.aspx
begining with ie11 vbscript is not recommended to work with in browsers!
download the compiled version in the link below.
*Begin Code
Publi m.Yform,m.yrep0
m.yrep0=Addbs(Justpath(Sys(16,1)))
Yform=Newobject("yviewerH")
Yform.Show
Read Events
Return
*
Define Class yviewerh As Form
BorderStyle = 3
Height = 638
Width = 924
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "yImage_viewer Horizontal"
BackColor = Rgb(0,0,0)
yclic = 0
ll = .F.
ww = .F.
tt = .F.
hh = .F.
xleft = .F.
xtop = .F.
xwidth = .F.
xheight = .F.
ybgcolor = .F.
Add Object image1 As Image With ;
Anchor = 15, ;
Stretch = 2, ;
BorderStyle = 1, ;
Height = 395, ;
Left = 101, ;
MousePointer = 15, ;
Top = 10, ;
Visible = .F., ;
Width = 756, ;
Name = "Image1"
Add Object timer1 As Timer With ;
Top = 36, ;
Left = 48, ;
Height = 23, ;
Width = 23, ;
Enabled = .F., ;
Interval = 3000, ;
Name = "Timer1"
Add Object image2 As Image With ;
Picture =m.yrep0+ "bigrotation2.gif", ;
Height = 32, ;
Left = 468, ;
Top = 252, ;
Visible = .F., ;
Width = 32, ;
Name = "Image2"
Add Object obrowser As OleControl With ;
oleclass="Shell.explorer.2",;
Top = 408, ;
Left = 2, ;
Height = 192, ;
Width = 918, ;
Visible = .F., ;
Anchor = 0, ;
Name = "oBrowser"
Add Object check1 As Checkbox With ;
Top = 614, ;
Left = 310, ;
Height = 17, ;
Width = 60, ;
Anchor = 768, ;
Alignment = 0, ;
BackStyle = 0, ;
Caption = "Tooltips", ;
Value = 1, ;
ToolTipText = "Image infos", ;
ForeColor = Rgb(255,0,0), ;
mousepointer=15,;
Name = "Check1"
Add Object image3 As Image With ;
Anchor = 768, ;
Picture = Home(1)+"graphics\icons\win95\openfold.ico", ;
Stretch = 2, ;
BackStyle = 0, ;
Height = 30, ;
Left = 236, ;
MousePointer = 15, ;
Top = 608, ;
Width = 37, ;
ToolTipText = "Images folder", ;
Name = "Image3"
Add Object command1 As CommandButton With ;
Top = 611, ;
Left = 404, ;
Height = 25, ;
Width = 120, ;
FontBold = .T., ;
Anchor = 768, ;
Caption = "Diaporama WMP", ;
MousePointer = 15, ;
BackColor = Rgb(0,255,0), ;
Name = "Command1"
Add Object command3 As CommandButton With ;
Top = 611, ;
Left = 527, ;
Height = 22, ;
Width = 80, ;
FontBold = .T., ;
Anchor = 768, ;
Caption = "BGcolor", ;
MousePointer = 15, ;
ToolTipText = "browser Bgcolor", ;
BackColor = Rgb(0,255,0), ;
Name = "Command3"
Add Object check2 As Checkbox With ;
Top = 615, ;
Left = 615, ;
Height = 17, ;
Width = 33, ;
FontBold = .T., ;
Anchor = 768, ;
AutoSize = .T., ;
Alignment = 0, ;
BackStyle = 0, ;
Caption = "TB", ;
Value = 0, ;
MousePointer = 15, ;
ToolTipText = "Titlebar on/off", ;
ForeColor = Rgb(255,0,0), ;
Name = "Check2"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 16, ;
Anchor = 768, ;
WordWrap = .F., ;
BackStyle = 0, ;
Caption = "?", ;
Height = 27, ;
Left = 660, ;
MousePointer = 15, ;
Top = 613, ;
Width = 16, ;
ForeColor = Rgb(0,255,0), ;
fontbold=.T.,;
ToolTipText = "Summary help", ;
Name = "Label1"
Procedure ybuild
Thisform.image2.Visible=.T.
Sele ycurs
Locate
Local ystr
m.ystr="<table><tr>"
Scan
m.ystr=m.ystr+'<td><img src="file:///'+Allt(yimage)+'" alt='+Justfname(yimage)+' ID=y'+Trans(Recno())+' width="130" height="120" style="cursor:pointer" onclick="yview(this.src)" onMouseEnter="onmouseIn(this)" onmouseleave="OnMouseOut(this)"></td>'
Endscan
m.ystr=m.ystr+"</tr></table>"
Local m.myvar
TEXT to m.myvar textmerge noshow
<html>
<head>
<script type="text/javascript">
function onmouseIn (elem) {
elem.style.border = "2px solid white";
}
function OnMouseOut (elem) {
elem.style.border = "";
}
function yview(x){
oVFP.image1.visible=true;
oVFP.yview(x);
}
</script>
<script LANGUAGE="VBSCRIPT">
DIM oVFP 'public variable!
Function SetVFPObject(loVFP)
Set oVFP = loVFP 'assign to public
End Function
</script>
</head>
<body bgcolor=<<thisform.ybgcolor>> scroll="yes">
<<m.ystr>>
</body></html>
ENDTEXT
Local oo
oo=Addbs(Sys(2023))+"yim*.html"
Dele File (m.oo)
Local m.lcdest
m.lcdest=Addbs(Sys(2023))+"yim"+Sys(2015)+".html"
Strtofile(m.myvar,m.lcdest)
Thisform.obrowser.Navigate(m.lcdest)
**
Thisform.Resize()
Thisform.obrowser.Visible=.T.
Thisform.timer1.Enabled=.T.
Endproc
Procedure yview
Lparameters im
Thisform.image1.Picture=Strtran(im,"file:///","")
Endproc
Procedure yset
Thisform.obrowser.Document.Script.SetVFPObject(Thisform)
Thisform.image2.Visible=.F.
Thisform.obrowser.Document.getElementById("y1").focus
Thisform.obrowser.Document.getElementById("y1").Click
Endproc
Procedure QueryUnload
*the browser dont quit and vfp dont close correctly.this is a way to make vfp clsoing in destry event
Thisform.obrowser.Navigate("about:blank")
Endproc
Procedure Init
With Thisform
.SetAll("mousepointer",15,"commandbutton")
.SetAll("mousepointer",15,"label")
Endwith
Publi yrep
Thisform.check2.Value=0
Endproc
Procedure Resize
With Thisform.image1
.Left=(Thisform.Width-.Width)/2
Endwith
With Thisform.obrowser
.Left=0
.Top=Thisform.Height-.Height-Thisform.image3.Height-16
.Width=.Parent.Width-15
Endwith
Endproc
Procedure Destroy
Clea Events
Endproc
Procedure Load
Declare Integer Sleep In kernel32 Integer
Endproc
Procedure image1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
Local m.x,m.lcfilename
m.lcfilename=This.Picture
If Empty(m.lcfilename)
Return .F.
Endi
x=m.lcfilename+Chr(13)+Chr(10)
Dimension arrHeaders(35)
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))
x=x+Trans(i)+" "+ arrHeaders(i) +" "+": " + objFolder.GetDetailsOf(strFileName, i)+Chr(13)
Endi
Next
Endi
Next
This.ToolTipText=m.x
Endproc
Procedure image1.Click
Thisform.yclic=Thisform.yclic+1
If Thisform.yclic>1
Thisform.yclic=0
Endi
Local x,Y,w,h
Do Case
Case Thisform.yclic=1
With Thisform
.ll=.image1.Left
.tt=.image1.Top
.ww=.image1.Width
.hh=.image1.Height
.image1.ZOrder(0)
.xleft=.Left
.xtop=.Top
.xwidth=.Width
.xheight=.Height
.obrowser.Visible=.F.
.Top=-Sysmetric(9)-Sysmetric(4)
.Width=Sysmetric(1)+2*Sysmetric(3)
.Height=Sysmetric(2)+Sysmetric(9)+Sysmetric(4)
.Left=-2*Sysmetric(3)
.image1.Top=-1
.image1.Left=0
.image1.Width=.Width
.image1.Height=.Height
Endwith
Case Thisform.yclic=0 &&restaure form
With Thisform
.Left=.xleft
.Top=.xtop
.Width=.xwidth
.Height=.xheight
With .image1
.Left=Thisform.ll
.Top=Thisform.tt
.Width=Thisform.ww
.Height=Thisform.hh
Endwith
.obrowser.Visible=.T.
Endwith
Endcase
Thisform.Resize()
Endproc
Procedure timer1.Timer
Local t0
t0=Datetime()
Do While Thisform.obrowser.busy Or Thisform.obrowser.readystate#4 &&
Sleep(100)
If Datetime()-t0>=70 &&70 sec
Exit
Endi
Enddo
This.Enabled=.F.
Thisform.yset()
Endproc
Procedure image2.Init
With This
.Left=(Thisform.Width-.Width)/2
Endwith
Endproc
Procedure obrowser.Refresh
*** Méthode de contrôle ActiveX ***
Endproc
Procedure check1.Click
Thisform.ShowTips=This.Value
Endproc
Procedure image3.Click
m.yrep=Getdir()
If Empty(m.yrep)
Return .F.
Endi
gnbre=Adir(gabase,Addbs(m.yrep)+"*.*")
If gnbre=0
Return .F.
Endi
Create Cursor ycurs (yimage c(200))
For i=1 To gnbre
If Inlist(Lower(Justext(gabase(i,1))),"jpg","bmp","png","gif")
Insert Into ycurs Values(Addbs(m.yrep)+gabase(i,1))
Endi
Endfor
Sele ycurs
Locate
Thisform.yclic=0
Thisform.ybuild()
Endproc
Procedure command1.Click
*play a diaporama of a photo folder wirh WMP-
Sele ycurs
Locate
Local m.ystr,cr
m.ystr=""
m.cr=Chr(13)+Chr(10)
Scan
m.ystr=m.ystr+Allt(yimage)+cr
Endscan
Local m.lcdest
m.lcdest=Addbs(Sys(2023))+"ydiapo_WMP.m3u"
Dele File Addbs(Sys(2023))+"ydapo*.m3u"
Strtofile(m.ystr,m.lcdest)
Thisform.WindowState=1
&&shellexecute
Declare Integer ShellExecute In SHELL32.Dll Integer nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
result = ShellExecute(0, "open", m.lcdest,"","",3) &&wmp set as default reader
*****
Inke(2)
Local oshell
oshell=Newobject("wscript.shell")
oshell.sendkeys("%{ENTER}") &&fullscreen
Endproc
Procedure command3.Click
Local tncolor
tncolor=Getcolor()
If m.tncolor=-1
Return .F.
Endi
Local loColor
loColor = Createobject("Empty")
AddProperty(loColor, "nR", Bitand(tncolor, 0xFF))
AddProperty(loColor, "nG", Bitand(Bitrshift(tncolor, 8), 0xFF))
AddProperty(loColor, "nB", Bitand(Bitrshift(tncolor, 16), 0xFF))
AddProperty(loColor, "cHTMLcolor", Strtran("#" + ;
TRANSFORM(loColor.nR, "@0") + ;
TRANSFORM(loColor.nG, "@0") + ;
TRANSFORM(loColor.nB, "@0"), "0x000000", "" ))
Thisform.ybgcolor=m.loColor.chtmlcolor
Thisform.BackColor=m.tncolor
Thisform.ybuild()
Endproc
Procedure check2.InteractiveChange
Do Case
Case This.Value=0 &&normal
With Thisform
.TitleBar=1
.Height=.Height-15
Endwith
Case This.Value=1 &&without titlebar
With Thisform
.TitleBar=0
.Height=.Height+15
Endwith
Endcase
Endproc
Procedure check2.Click
Endproc
Procedure label1.Click
Local m.myvar
TEXT to m.myvar noshow
This code uses the vfp olecontrol browser to gather all images in any folder
on disc with format (jpg,png,bmp,gif) and display them as an horizontal
pellicule.
click on any vignette to see it .If tooltip is checked can see all informations
relative to this image.
-can make form maximize or resize it with title bar or no.
-can make image viewed on fullscreen mode.
-can change the background color
*the code uses javascript to dialog with vfp (see the method form.ybuild() & form.yset()
*javascript Function SetVFPObject(loVFP)(Idea tanks to WestWInd)
-A diaporama can be viewed with all photos with the default mediaplayer (WMP).
-The browser can embed a remarquable quantity of images without any problem.
NB:the animated gif bigrotation2.gif must be in folder
ENDTEXT
Messagebox(m.myvar,0x1000,"Summary help")
Endproc
Enddefine
*End Code
download the animated gif bigrotation.gif to work with the code.
Can download the same code compiled exe version of this code (compiled under win8.1 and working also on windows10 )