OLE DRAG & DROP in VISUAL FOXPRO
i published a post relative to oledrag & drop in visual foxpro - 6 november 2014 in this Foxite link:
https://www.foxite.com/archives/drag-images-from-explorer-firefox-0000414145.htm
infortunatly this was worked on windows8.1 if i remember.When upgraded to windows 10 professional this code have any longer and i wondered if microsoft go to correct this bug.
these last days i re try the code and by luck it worked.Ms corrected this bug through its updates.
the code make drag & drop operations from restricted tested sources as
-firefox (works with images and text.protected images as google dont work)
-windows explorer: work (files)
-chrome( work for text only)
-IE dont work on images nor on text !
....
Select any image and drag&drop into the relative form(Firefox,explorer)
Select a text (ex from vfp command window or firefox or explorer txt file) and drag& drop into the form
the images captured are saved in captures folder as BMP and converted by APIS to light jpg ones.
notes:
-i choose the JPG light format for captures.can choose another format (PNG,GIF,BMP,...in code)
-the ANSI text can be saved as txt file from the relative form.
if you drag unicode text towards the vfp editbox you get "???"(must use rtfbox instead or ms textbox activeX its unicode).
-the temp images used by Firefox are deleted automatically by system after some time.cannot clean them from vfp.
-Can build a project, add a config.fpw and compile an exe as utility (20 ko).
Added on Thursday 28 april 2016:
-the oledrag & drop of unicode texts (tested here on arabic).
-corected contextuel menu (replaced by flat code - mpr not shipped previously).
note: to make Firefox.exe (or iexplore.exe, chrome.exe.....), launched automatically without specifing the location path can use this command line(type in windows start):
setx path "%path%;C:\Program Files\Mozilla Firefox"
Click on code to select [then copy] -click outside to deselect
*1*
*oledrag & drop images or ANSI text (2 options on 2 forms)
If !_vfp.StartMode=0
On Shutdown Quit
Endi
Set Safe Off
Clea All
Publi m.yrep
m.yrep=Addbs(Justpath(Sys(16,1)))
Set Defa To (yrep)
If !Directory(m.yrep+"captures") &&create a folder captures if not exist
Md (m.yrep+"captures")
Endi
*download a fox image from my blog
Declare Integer Sleep In kernel32 Integer
Declare Integer URLDownloadToFile In urlmon.Dll Integer pCaller, String szURL, String szFileName, Integer dwReserved, Integer lpfnCB
Declare Integer DeleteUrlCacheEntry In wininet String lpszUrlName
lcDownloadURL = "http://img.over-blog-kiwi.com/1/43/54/07/20160422/ob_6577e4_yfennec.png"
lcDownloadLoc ="yfennec.png"
lnResult = DeleteUrlCacheEntry(lcDownloadURL)
lnResult = URLDownloadToFile(0, lcDownloadURL, lcDownloadLoc , 0,0)
If lnResult = 0
Wait Window "Download "+lcDownloadLoc +" Complete" Nowait
*Else
*!* Messagebox("Download fails")
Endi
Local m.x
m.x=Inputbox("oledrag image(1)-oledragText(2)","","1")
If !Inlist(m.x,"1","2")
Return .F.
Endi
Publi yform
Do Case
Case m.x="1"
*do form ydragDrop_Img
yform=Newobject("yoledrag_drop_img")
Case m.x="2"
yform=Newobject("yOledrag_drop_text")
*do form yoledragdrop_texts
Otherwise
Return .F.
Endcase
yform.Show
Read Events
Define Class yoledrag_drop_img As Form
Top = 0
Left = 12
Height = 392
Width = 456
ShowWindow = 2
BackColor=Rgb(212,208,200)
ShowTips = .T.
Picture = ""
Caption = "Visual Fox Dragdrop images from anywhere !"
MaxButton = .F.
Icon = Home(1)+"graphics\icons\misc\misc15.ico"
WindowState = 0
AlwaysOnTop = .T.
xpict = .F.
ycl = 0
xleft = .F.
xtop = .F.
xwidth = .F.
xheight = .F.
Name = "Form1"
Add Object image1 As Image With ;
OLEDragMode = 1, ;
OLEDropMode = 1, ;
Anchor = 15, ;
Picture = "yfennec.png", ;
Stretch = 2, ;
Height = 348, ;
Left = 2, ;
MousePointer = 15, ;
Top = 0, ;
Width = 450, ;
ToolTipText = "", ;
Name = "Image1"
Add Object image2 As Image With ;
Anchor = 768, ;
backstyle=0, ;
Picture = Home(1)+ "graphics\icons\win95\explorer.ico", ;
Stretch = 2, ;
Height = 36, ;
Left = 162, ;
MousePointer = 15, ;
Top = 357, ;
Width = 54, ;
ToolTipText = "See captured images", ;
Name = "Image2"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 20, ;
Anchor = 768, ;
BackStyle = 0, ;
Caption = "?", ;
Height = 35, ;
Left = 230, ;
MousePointer = 15, ;
Top = 354, ;
Width = 19, ;
ForeColor = Rgb(128,0,64), ;
ToolTipText = "Summary help", ;
Name = "Label1"
Procedure Load
Declare Integer OpenClipboard In User32 Integer
Declare Integer CloseClipboard In User32
Declare Integer EmptyClipboard In User32
Declare Integer SetClipboardData In User32 Integer,Integer
Declare Integer GetClipboardData In User32 Integer
Declare Integer GdipSaveImageToFile In GDIPlus.Dll Integer,String,String @,String @
Declare Long GdipCreateHBITMAPFromBitmap In GDIPlus.Dll Long nativeImage, Long @, Long
Declare Long CopyImage In WIN32API Long hImage, Long, Long, Long , Long
Declare Long GdipCreateBitmapFromFile In GDIPlus.Dll String FileName, Long @nBitmap
Declare Integer GdipCreateBitmapFromHBITMAP In GDIPlus.Dll Integer, Integer, Integer @
Endproc
Procedure zsave
Lparameters yimage
#Define CF_BITMAP 2
#Define IMAGE_BITMAP 0
#Define LR_DEFAULTSIZE 0x00000040
Local m.ext
m.ext="JPG" &&can choose any image format :PNG,BMP,JPG,GIF,TIFF ....
Do Case
Case m.ext="PNG"
lqEncoderClsID_PNG=0h06F47C55041AD3119A730000F81EF32E &&PNGFormat
Case m.ext="JPG"
lqEncoderClsID_JPG=0h01F47C55041AD3119A730000F81EF32E &&JPGFormat
Case m.ext="BMP"
lqEncoderClsID_BMP=0h00F47C55041AD3119A730000F81EF32E &&BMPFormat
Case m.ext="GIF"
lqEncoderClsID_GIF=0h02F47C55041AD3119A730000F81EF32E &&GIFFormat
Case m.ext="TIF"
lqEncoderClsID_TIF=0h05F47C55041AD3119A730000F81EF32E &&TIFFormat
Endcase
*Save the graphic file to the clipboard
nBitmap=0
hbm=0
GdipCreateBitmapFromFile(Strconv(Allt(yimage)+0h00,5),@nBitmap)
GdipCreateHBITMAPFromBitmap(nBitmap,@hbm,0)
lhbmp=CopyImage(hbm,0, 0,0, LR_DEFAULTSIZE) &&no resize preserve dimensions as it
If OpenClipboard(0)!= 0
EmptyClipboard()
SetClipboardData(CF_BITMAP, lhbmp)
CloseClipboard()
Endif
*get the graphics from the local clipboard
OpenClipboard(0)
hBitmap = GetClipboardData(CF_BITMAP)
CloseClipboard()
*export as image file with any image extension on disc
Local lcoutputfile,lcoutputfile0,ubitmap
lcoutputfile0=m.yrep+"captures\"+Juststem(yimage)+"."+m.ext &&
ubitmap=0
GdipCreateBitmapFromHBITMAP(hBitmap,2,@ubitmap)
lcoutputfile=Strconv(m.lcoutputfile0+Chr(0),5)
GdipSaveImageToFile(ubitmap,lcoutputfile,Eval("lqEncoderClsID_"+m.ext),Null)
Thisform.image1.PictureVal=Filetostr(lcoutputfile0)
hBitmap=Null
Endproc
Procedure QueryUnload()
Clea Resources
Local gnbre
gnbre=Adir(gabase,Addbs(Sys(2023))+"*.bmp")
Wait Window (Trans(gnbre)+" BMPs in temp") Nowait
For i=1 To gnbre
Try
Dele File Addbs(Sys(2023))+gabase(i,1)
Catch
Endtry
Endfor
Clea Events
Endproc
Procedure Init
Declare Integer Sleep In kernel32 Integer
_Screen.WindowState=1
Thisform.xpict=""
With Thisform
.ycl=0
.Left=0
.Top=0
.xleft=.Left
.xtop=.Top
.xwidth=.Width
.xheight=.Height
Endwith
Endproc
Procedure image1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.ToolTipText="Drag any picture from explorer or FireFox navigator here-"+Chr(13)+"-Click=fullscreen"+Chr(13)+Thisform.xpict
*Contrary on Firefox,IE and Chrome dont accept oleDrag event
Endproc
Procedure image1.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
Endproc
Procedure image1.OLEDragDrop
Lparameters oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord
**********************************
*Foxhelp
*CF_TEXT 1 Text format.
*CF_OEMTEXT 7 Text format containing characters in the OEM character set.
*CF_UNICODETEXT 13 Unicode text format.
*NoteNote
*Available only for versions of Visual FoxPro running on Windows NT 4.0 or later.
*CF_FILES or CF_HDROP 15 A handle that identifies a list of files, such as a set of files dragged from the Windows Explorer.
*CFSTR_OLEVARIANTARRAY "OLE Variant Array" An array. Multiple values can be transferred in a single drag and drop operation with this format.
*For example, this format can be used to drag a set of items in a list box to another list box.
*
*CFSTR_OLEVARIANT "OLE Variant" A variant. All data types in Visual FoxPro are represented as variants. This format can be used to drag and drop Visual FoxPro data without losing the data type.
*CFSTR_VFPSOURCEOBJECT "VFP Source Object" A reference to the Visual FoxPro drag source object.
* Defined in FOXPRO.H.
TEXT to _cliptext textmerge noshow
1-<<oDataObject.GetFormat(1)>>-Text format
7-<<oDataObject.GetFormat(7)>>-Text format containing characters in the OEM character se
13-<<oDataObject.GetFormat(13)>>-Unicode text format
15-<<oDataObject.GetFormat(15)>>-a list of files,
-ole variant array : <<oDataObject.GetFormat("ole variant array")>>
-"ole variant : <<oDataObject.GetFormat("olevariant")>>
-vfp source object:<<oDataObject.GetFormat("vfp source object")>>
ENDTEXT
x=_Cliptext
Messagebox(x,0+32+4096,"odataObject",1500)
Local cfilename, afiles[ 1 ]
If oDataObject.GetFormat( 15 ) &&files
oDataObject.GetData( 15, @afiles )
For Each cfilename In afiles
Do Case
Case Lower(Justpath(m.cfilename))==Lower(Sys(2023)) &&temp folder (Firefox)
Thisform.zsave(cfilename)
Otherwise &&explorer
Copy File (cfilename) To (m.yrep+"captures")
Thisform.xpict=m.yrep+"captures\"+Justfname(cfilename)
Thisform.image1.PictureVal=Filetostr(Thisform.xpict)
Endcase
Inkey( .5 )
Next
Endif
Endproc
Procedure image1.OLEDragOver
Lparameters oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord, nState
Do Case
Case nState = 0 && Drag Enter
If oDataObject.GetFormat(15)
This.OLEDropHasData = 1
This.OLEDropEffects = 4
nEffect = 4
Endif
Case nState = 1 && DRAG_LEAVE
Case nState = 2 && DRAG_OVER
Endcase
Thisform.Refresh
Endproc
Procedure image1.MouseEnter
Lparameters nButton, nShift, nXCoord, nYCoord
This.ToolTipText="Drag any picture from explorer or FireFox navigator here-"+Chr(13)+"-Click=fullscreen"+Chr(13)+Thisform.xpict
*Contrary on Firefox,IE and Chrome dont accept oleDrag event
Endproc
Procedure image2.Click
Local oo
m.oo=m.yrep+"captures"
Thisform.WindowState=1
Run /N explorer &oo
Endproc
Procedure label1.Click
Local m.myvar
TEXT to m.myvar noshow
this application uses the VFP oleDrag event to capture any image from
-the windows explorer (image saved as it)
-the Firefox browser (IE and Chrome dont accept oleDrag...another
dont tried.): image intercepted and saved as bmp and converted to JPG
with APIs.
-Drag any image from explorer or Firefox into the image control
and its saved in the "captures" folder of this application.
-Can see all captures produced
-Can make the image on fullscren( first click) and restaure the
form (seconf click).
Author Yousfi Benameur ElBayadh Algeria
Thursday 6 november 2014
ENDTEXT
Messagebox(m.myvar,0+32+4096,"Summary help")
Endproc
Procedure Destroy
Clea Events
Endproc
Enddefine
*
*-- EndDefine: yoledrag_drop_img
*
Define Class yOledrag_drop_text As Form
Top = 0
Left = 0
Height = 396
Width = 732
ShowWindow = 2
Caption = "yOledradrop_texts"
AlwaysOnTop = .T.
BackColor = Rgb(72,72,72)
Icon=Home(1)+"graphics\icons\misc\misc15.ico"
Name = "Form1"
Add Object edit1 As EditBox With ;
OLEDragMode = 1, ;
OLEDropMode = 1, ;
Anchor = 15, ;
Height = 324, ;
Left = 7, ;
Top = 36, ;
Width = 713, ;
Name = "Edit1"
Add Object label1 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
Anchor = 768, ;
BackStyle = 0, ;
Caption = "Dragdrop texts from anywhere if client operation supported", ;
Height = 20, ;
Left = 36, ;
Top = 0, ;
Width = 429, ;
ForeColor = Rgb(255,0,0), ;
Name = "Label1"
Add Object label2 As Label With ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
BackStyle = 0, ;
Caption = "", ;
Height = 20, ;
Left = 480, ;
Top = 1, ;
Width = 2, ;
ForeColor = Rgb(0,255,0), ;
Name = "Label2"
Add Object command1 As CommandButton With ;
Top = 370, ;
Left = 299, ;
Height = 25, ;
Width = 133, ;
Anchor = 768, ;
Caption = "Save as txt file", ;
MousePointer = 15, ;
Name = "Command1"
Procedure Destroy
Clea Events
Endproc
Procedure edit1.OLEDragDrop
Lparameters oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord
Local i, cText, cNewStr
Do Case
***************
*case oDataObject.Getformat(15) &&files from explorer
*This.Value =oDataObject.GetData(15)
**CF_FILES or CF_HDROP 15 A handle that identifies a list of files, such as a set of files dragged from the Windows Explorer.
********************
Case oDataObject.GetFormat(1) &&1-CF_TEXT
This.Value =oDataObject.GetData(1)
Thisform.label2.Caption="-1-CF_TEXT"
Case oDataObject.GetFormat(7) &&7 CF_OEMTEXT Text format containing characters in the OEM character set.
This.Value =oDataObject.GetData(7)
Thisform.label2.Caption="-7 CF_OEMTEXT"
Case oDataObject.GetFormat(13) &&13-CF_UNICODETEXT Unicode text format.
Local m.cFontName,m.cFontCharset,m.cfilename,m.cfilename1,m.nRegionalIDType
m.cFontName = 'Tahoma' && unicode font
m.cFontCharset = 178 && see getfont() in foxHelp (178=arabic)
m.nRegionalIDType=2 && Specifies that nRegionalIdentifier is a FontCharSet value.
Thisform.setfontcharset(Thisform.edit1,m.cFontName ,oDataObject.GetData(13) , m.cFontCharset,m.nRegionalIDType)
Thisform.edit1.Value= Strconv(Substr(oDataObject.GetData(13),3), 11, nCharSet, nRegionalIDType)
Thisform.label2.Caption="-13-CF_UNICODETEXT"
Endcase
Nodefault
Endproc
Procedure edit1.RightClick
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
Define Bar _Med_cut Of raccourci Prompt "\<Couper" ;
KEY CTRL+x, "Ctrl+X" ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
Define Bar _Med_copy Of raccourci Prompt "Co\<pier" ;
KEY CTRL+C, "Ctrl+C" ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
Define Bar _Med_paste Of raccourci Prompt "C\<oller" ;
KEY CTRL+V, "Ctrl+V" ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
Define Bar _Med_find Of raccourci Prompt "Rec\<hercher..." ;
KEY CTRL+F, "Ctrl+F" ;
MESSAGE "Recherche le texte spécifié"
Define Bar _Med_slcta Of raccourci Prompt "Sélec\<tionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
Define Bar _Med_redo Of raccourci Prompt "\<Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
MESSAGE "Rétablit la dernière opération annulée"
Define Bar _Med_undo Of raccourci Prompt "\<Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
MESSAGE "Annule la dernière modification"
Activate Popup raccourci
Endproc
Procedure command1.Click
Set Defa To (m.yrep+"captures")
Strtofile(Thisform.edit1.Value,Forceext(Putfile('txt'),'txt') )
Set Defa To (m.yrep)
Endproc
Enddefine
*
*-- EndDefine: yOledradrop_text
Click on code to select [then copy] -click outside to deselect
*2* this code works with unicode texts.the oleDrag&drop operation is tested from an arabic web page on Firefox and chrome (no IE11).this works well and the text in editbox is arabic.it can be saved to an utf-8 txt file (using strconv(string,9,178,2).
Note : i cut the clipboard data relative to ansi text (seems to take superiority on unicode text) and all works well in code
publi yform
yform=newObject("yoledd")
yform.show
read events
retu
*
DEFINE CLASS yoleDD AS form
Top = 0
Left = 0
Height = 396
Width = 732
ShowWindow = 2
borderstyle=2
Caption = "yOledradrop_texts unicodes"
AlwaysOnTop = .T.
BackColor = RGB(72,72,72)
Name = "Form1"
ADD OBJECT edit1 AS editbox WITH ;
OLEDragMode = 1, ;
OLEDropMode = 1, ;
FontBold = .T., ;
FontName = "Tahoma", ;
FontSize = 11, ;
FontCharSet = 178, ;
Anchor = 15, ;
Alignment = 1, ;
Height = 324, ;
Left = 7, ;
Top = 36, ;
Width = 713, ;
RightToLeft = .T., ;
Name = "Edit1"
ADD OBJECT label1 AS label WITH ;
anchor=768, ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
Anchor = 768, ;
BackStyle = 0, ;
Caption = "Dragdrop texts from anywhere if client operation supported", ;
Height = 20, ;
Left = 36, ;
Top = 0, ;
Width = 429, ;
ForeColor = RGB(255,0,0), ;
Name = "Label1"
ADD OBJECT label2 AS label WITH ;
anchor=768, ;
AutoSize = .T., ;
FontBold = .T., ;
FontSize = 11, ;
BackStyle = 0, ;
Caption = "", ;
Height = 20, ;
Left = 480, ;
Top = 1, ;
Width = 2, ;
ForeColor = RGB(0,255,0), ;
Name = "Label2"
ADD OBJECT command2 AS commandbutton WITH ;
anchor=768, ;
Top = 367+5, ;
Left = 290, ;
Height = 25, ;
Width = 204, ;
FontBold = .T., ;
Caption = "Save as UTF-8 txt file", ;
MousePointer = 15, ;
BackColor = RGB(128,255,0), ;
Name = "Command2"
ADD OBJECT label3 AS label WITH ;
anchor=768, ;
BackStyle = 0, ;
Caption = "Rightclick editbox for contextuel menu", ;
Height = 25, ;
Left = 14, ;
Top = 368+3, ;
Width = 226, ;
ForeColor = RGB(255,255,0), ;
Name = "Label3"
PROCEDURE Init
if !vartype(m.yrep)=="C"
publi m.yrep
m.yrep=addbs(justpath(sys(1271,this)))
set defa to (yrep)
endi
set safe off
_screen.windowstate=1
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE edit1.Init
Local m.cFontName,m.cFontCharset,m.cFileName,m.cfilename1,m.nRegionalIDType
m.cFontName = 'Tahoma' && unicode font
m.cFontCharset = 178 && see getfont() in foxHelp (here test on 178=arabic)
m.nRegionalIDType=2
this.fontCharset=m.cFontCharset
this.fontname=m.cfontname
ENDPROC
PROCEDURE edit1.RightClick
DEFINE POPUP raccourci SHORTCUT RELATIVE FROM MROW(),MCOL()
DEFINE BAR _med_cut OF raccourci PROMPT "\<Couper" ;
KEY CTRL+X, "Ctrl+X" ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
DEFINE BAR _med_copy OF raccourci PROMPT "Co\<pier" ;
KEY CTRL+C, "Ctrl+C" ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
DEFINE BAR _med_paste OF raccourci PROMPT "C\<oller" ;
KEY CTRL+V, "Ctrl+V" ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
DEFINE BAR _med_find OF raccourci PROMPT "Rec\<hercher..." ;
KEY CTRL+F, "Ctrl+F" ;
MESSAGE "Recherche le texte spécifié"
DEFINE BAR _med_slcta OF raccourci PROMPT "Sélec\<tionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
DEFINE BAR _med_redo OF raccourci PROMPT "\<Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
MESSAGE "Rétablit la dernière opération annulée"
DEFINE BAR _med_undo OF raccourci PROMPT "\<Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
MESSAGE "Annule la dernière modification"
ACTIVATE POPUP raccourci
ENDPROC
PROCEDURE edit1.OLEDragDrop
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord
LOCAL i, cText, cNewStr
do case
***************
*case oDataObject.Getformat(15) &&files from explorer &&this takes priority on unicode ?? uncommented.
*This.Value =oDataObject.GetData(15)
**CF_FILES or CF_HDROP 15 A handle that identifies a list of files, such as a set of files dragged from the Windows Explorer.
********************
case oDataObject.Getformat(7) &&7 CF_OEMTEXT Text format containing characters in the OEM character set.
This.Value =oDataObject.GetData(7)
thisform.label2.caption="-7 CF_OEMTEXT"
case oDataObject.Getformat(13) &&13-CF_UNICODETEXT Unicode text format.
This.Value =oDataObject.GetData(13)
Local m.cFontName,m.cFontCharset,m.cFileName,m.cfilename1,m.nRegionalIDType
m.cFontName = 'Tahoma' && unicode font
m.cFontCharset = 178 && see getfont() in foxHelp (178=arabic)
m.nRegionalIDType=2 && Specifies that nRegionalIdentifier is a FontCharSet value.
*Thisform.setfontcharset(Thisform.edit1,m.cFontName ,oDataObject.GetData(13) , m.cFontCharset,m.nRegionalIDType)
thisform.edit1.value= Strconv(Substr(oDataObject.GetData(13),3), 6, cFontCharSet, nRegionalIDType) &&unicode to double bits
thisform.label2.caption="-13-CF_UNICODETEXT"
case oDataObject.Getformat(1) &&1-CF_TEXT
This.Value =oDataObject.GetData(1)
thisform.label2.caption="-1-CF_TEXT"
endcase
NODEFAULT
ENDPROC
PROCEDURE command2.Click
set defa to (m.yrep+"captures")
local m.x,m.oo,m.uu
m.x=strconv(thisform.edit1.value,9,178,2)
m.oo=m.yrep+"captures\blank.txt"
m.uu=int(val(inputbox("Overwrite txt(0)-Append txt (1)","","0")))
if !between (m.uu,0,1)
m.uu=0
endi
if m.uu=0
=strtofile(m.x,m.oo)
else
=strtofile(m.x,m.oo,.t.)
endi
thisform.windowstate=1
set defa to (m.yrep)
run/n notepad &oo
ENDPROC
ENDDEFINE
*
*-- EndDefine: yoleDD
Note:run MSpaint and position it side with firefox window. if you drag manually image directly from Firefox into MSPAINT this success in my FF50.1.0. its not the case with iexplore.
Click on code to select [then copy] -click outside to deselect
*3*
*created on 25 of february 2017
*!*this is a better replacement for the code *1* above.it works on modern navigators unless some prealable settings in IE11.
*!* can execute ie (complet interface), ie application,firefox, chrome (if exits on system) or windows explorer
*!* from these windows can oledragdeop text (editbox,textbox) or pictures(warning there is some links whose are not picture but mask a navigation to a picture)
*!* if picture:
*!* - on textbox or editbox (retrieve the link picture as text)
*!* -on the image it retrieves the real image (if link is real picture or blob picture)
*!* if text oledragged from the fired application , its copied in textbox (one line) or in editbox (multiline).
*!* added a contextuel menu to this editbox.
*!* for IE11,must in internet options uncheck the protected mode otherwise no oledragdrop
*!* (ie11/menu/tools/internet options/security tab: unchecjk protectd mode).
*!* or run separatly IE11 as administrator
*!* for firefox,chrome,explorer: no problem.
*!* Right click on the image control to save the picture in images folder created in code (save pictureVal blob as picture or picture converted to pictureval from explorer).
publi yform
yform=newObject("yoleDD5")
yform.show
read events
retu
*
DEFINE CLASS yoleDD5 AS form
Height = 553
Width = 479
ShowWindow = 2
ShowTips = .T.
AutoCenter = .T.
Caption = "oleDragDrop from navigators and explorer demo"
MinHeight = 400
MinWidth = 400
AlwaysOnTop = .T.
BackColor = RGB(212,210,208)
Name = "Form1"
ADD OBJECT optiongroup1 AS optiongroup WITH ;
AutoSize = .T., ;
ButtonCount = 5, ;
Anchor = 768, ;
Value = 1, ;
Height = 27, ;
Left = 45, ;
Top = 12, ;
Width = 391, ;
Name = "Optiongroup1", ;
Option1.Caption = "IE11", ;
Option1.Value = 1, ;
Option1.Height = 17, ;
Option1.Left = 5, ;
Option1.Style = 0, ;
Option1.Top = 5, ;
Option1.Width = 43, ;
Option1.AutoSize = .T., ;
Option1.Name = "Option1", ;
Option2.Caption = "IE Application", ;
Option2.Height = 17, ;
Option2.Left = 61, ;
Option2.Style = 0, ;
Option2.Top = 5, ;
Option2.Width = 92, ;
Option2.AutoSize = .T., ;
Option2.Name = "Option2", ;
Option3.Caption = "Firefox", ;
Option3.Height = 17, ;
Option3.Left = 168, ;
Option3.Style = 0, ;
Option3.Top = 5, ;
Option3.Width = 54, ;
Option3.AutoSize = .T., ;
Option3.Name = "Option3", ;
Option4.Caption = "Chrome", ;
Option4.Height = 17, ;
Option4.Left = 241, ;
Option4.Style = 0, ;
Option4.Top = 5, ;
Option4.Width = 63, ;
Option4.AutoSize = .T., ;
Option4.Name = "Option4", ;
Option5.Caption = "Explorer", ;
Option5.Height = 17, ;
Option5.Left = 323, ;
Option5.Style = 0, ;
Option5.Top = 5, ;
Option5.Width = 63, ;
Option5.AutoSize = .T., ;
Option5.Name = "Option5"
ADD OBJECT image1 AS image WITH ;
OLEDragMode = 1, ;
OLEDropMode = 1, ;
Anchor = 15, ;
Stretch = 2, ;
Height = 363, ;
Left = 17, ;
Top = 136, ;
Width = 456, ;
Name = "Image1"
ADD OBJECT text1 AS textbox WITH ;
OLEDragMode = 1, ;
OLEDropMode = 1, ;
FontName = "MS Sans Serif", ;
FontSize = 8, ;
Anchor = 768, ;
Height = 32, ;
Left = 43, ;
Top = 516, ;
Width = 396, ;
BackColor = RGB(128,255,255), ;
Name = "Text1"
ADD OBJECT edit1 AS editbox WITH ;
OLEDragMode = 1, ;
OLEDropMode = 1, ;
Anchor = 0, ;
Height = 85, ;
Left = 8, ;
Top = 43, ;
Width = 469, ;
BackColor = RGB(255,221,204), ;
Name = "Edit1"
ADD OBJECT image2 AS image WITH ;
Anchor = 768, ;
Picture = home(1)+"graphics\bitmaps\tlbr_w95\help.bmp", ;
Stretch = 2, ;
BackStyle = 1, ;
BorderStyle = 1, ;
Height = 32, ;
Left = 443, ;
MousePointer = 15, ;
Top = 6, ;
Width = 32, ;
Name = "Image2"
ADD OBJECT yex AS image with ;
Picture = home(1)+"graphics\icons\win95\explorer.ico",;
BackStyle = 0,;
Height = 32,;
Left = 444,;
MousePointer = 15,;
Top = 516,;
Width = 32,;
ToolTipText = "Explore captures",;
Name = "yex"
PROCEDURE yex.Click
local m.oo
m.oo=m.yrep+"images"
run/n explorer &oo
ENDPROC
PROCEDURE Destroy
m.yrep=null
release m.yrep
clea events
ENDPROC
PROCEDURE Load
&&shellexecute
DECLARE INTEGER ShellExecute IN SHELL32.DLL INTEGER nWinHandle,;
STRING cOperation,;
STRING cFileName,;
STRING cParameters,;
STRING cDirectory,;
INTEGER nShowWindow
_screen.windowstate=1
ENDPROC
PROCEDURE Init
with this
.left=1
.top=1
.SetAll('Fontname', 'Tahoma')
.SetAll('Fontsize',8)
endwith
publi m.yrep
IF VARTYPE(SYS(1271, THISFORM)) = "L"
m.yrep = ADDBS(JUSTPATH(SYS(16, 1))) &&code runs as prg
ELSE
m.yrep = ADDBS(JUSTPATH(SYS(1271, THISFORM))) &&code runs as form
ENDIF
if !directory( m.yrep+"images")
md (m.yrep+"images")
endi
ENDPROC
PROCEDURE Resize
with thisform.edit1
.left=10
.width=thisform.width-20
endwith
ENDPROC
PROCEDURE optiongroup1.Init
with this
.setall("mousepointer",15,"optionbutton")
.setall("autosize",.t.,"optionbutton")
.setall("backstyle",0,"optionbutton")
.backstyle=0
.autosize=.t.
endwith
ENDPROC
PROCEDURE optiongroup1.Click
try
do case
case this.value=1
ShellExecute(0, "open", 'iexplore.exe',"http://yousfi.over-blog.com/2015/01/glass-images-effect-with-gdiplusx.html","",1)
case this.value=2
publi apie
apie=newObject("internetexplorer.application")
with apie
.navigate("http://yousfi.over-blog.com/2015/01/glass-images-effect-with-gdiplusx.html")
.visible=.t.
endwith
case this.value=3
ShellExecute(0, "open", 'Firefox.exe',"http://yousfi.over-blog.com/2015/01/glass-images-effect-with-gdiplusx.html","",1)
case this.value=4
ShellExecute(0, "open", 'chrome.exe',"http://yousfi.over-blog.com/2015/01/glass-images-effect-with-gdiplusx.html","",1)
case this.value=5
run/n explorer
endcase
catch
messagebox("not installed",16+4096,"Error")
endtry
ENDPROC
PROCEDURE image1.OLEDragOver
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord, nState
DO CASE
CASE nState == 0 &&DRAG_ENTER
DO CASE
CASE oDataObject.GetFormat("OLE Variant Array") && Array
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 1+2 &&DROPEFFECT_COPY + DROPEFFECT_MOVE
CASE oDataObject.GetFormat(1) && Text
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 1+2 &&DROPEFFECT_COPY + DROPEFFECT_MOVE
CASE oDataObject.GetFormat(15) && Files CF_HDROP
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 4 &&DROPEFFECT_LINK
OTHERWISE
This.OLEDropHasData = 0 &&DROPHASDATA_NOTUSEFUL
ENDCASE
CASE nState == 1 && Drag Leave
CASE nState == 2 && Drag Over
ENDCASE
ENDPROC
PROCEDURE image1.OLEDragDrop
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord
*-- Check to see whether the user wants to copy or move
IF nShift == 1
nOperation = 1 &&DROPEFFECT_COPY
ELSE
nOperation = 2 &&DROPEFFECT_MOVE
ENDIF
thisform.lockscreen=.t.
do case
case oDataObject.Getformat(1) &&CF_TEXT
cText = oDataObject.GetData(1)
********************
*using the pictureval property from web with MsXml2.XmlHttp responsebody
Local loRequest,lcUrl
m.lcUrl=allt(m.ctext)
try
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
This.pictureVal=m.loRequest.ResponseBody
m.loRequest=Null
catch
endtry
*********************************
case odataobject.GETFORMAT( 15 ) &&one file is oledragdopped in image only (from explorer here)
LOCAL cfilename, afiles[ 1 ]
odataobject.GETDATA( 15, @afiles )
For Each cfilename In afiles
THIS.PICTURE = cfilename
this.pictureval=filetostr(cfilename)
INKEY( .5 )
NEXT
endcase
thisform.lockscreen=.f.
*-- Set the nEffect parameter for communication back to the source object
nEffect = nOperation
retu
ENDPROC
PROCEDURE image1.Init
Local loRequest,lcUrl
lcUrl="http://img.over-blog-kiwi.com/1/43/54/07/20160422/ob_6577e4_yfennec.png"
try
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
This.pictureVal=m.loRequest.ResponseBody
m.loRequest=Null
catch
endtry
ENDPROC
PROCEDURE image1.RightClick
*nodefault &&context menu?
if empty(this.pictureval)
return .f.
endi
local m.lcdest
m.lcdest=m.yrep+"images\img_"+sys(2015)+'.jpg'
strtofile(this.pictureVal ,m.lcdest)
messagebox(m.lcdest+" saved",0+32+4096,'',1200)
ENDPROC
PROCEDURE text1.OLEDragOver
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord, nState
DO CASE
CASE nState == 0 &&DRAG_ENTER
DO CASE
CASE oDataObject.GetFormat("OLE Variant Array") && Array
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 1+2 &&DROPEFFECT_COPY + DROPEFFECT_MOVE
CASE oDataObject.GetFormat(1) && Text
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 1+2 &&DROPEFFECT_COPY + DROPEFFECT_MOVE
CASE oDataObject.GetFormat(15) && Files CF_HDROP
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 4 &&DROPEFFECT_LINK
OTHERWISE
This.OLEDropHasData = 0 &&DROPHASDATA_NOTUSEFUL
ENDCASE
CASE nState == 1 && Drag Leave
CASE nState == 2 && Drag Over
ENDCASE
ENDPROC
PROCEDURE text1.OLEDragDrop
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord
LOCAL i, cText, cNewStr
If oDataObject.Getformat(1) &&CF_TEXT
cText = oDataObject.GetData(1)
This.Value =cText
endif
if oDataObject.GetFormat(15) && Files CF_DROP (from explorer here)
DIMENSION aValues[1]
oDataObject.GetData(15, @aValues )
*-- Add each filename as a new item in the list
FOR i = 1 to 1 &&alen(aValues) if listbox
This.value=(aValues[m.i])
NEXT
ENDi
NODEFAULT
ENDPROC
PROCEDURE text1.Click
this.setfocus
keyboard "{CTRL+A}"
ENDPROC
PROCEDURE edit1.OLEDragOver
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord, nState
DO CASE
CASE nState == 0 &&DRAG_ENTER
DO CASE
CASE oDataObject.GetFormat("OLE Variant Array") && Array
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 1+2 &&DROPEFFECT_COPY + DROPEFFECT_MOVE
CASE oDataObject.GetFormat(1) && Text
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 1+2 &&DROPEFFECT_COPY + DROPEFFECT_MOVE
CASE oDataObject.GetFormat(15) && Files CF_HDROP
This.OLEDropHasData = 1 &&DROPHASDATA_USEFUL
This.OLEDropEffects = 4 &&DROPEFFECT_LINK
OTHERWISE
This.OLEDropHasData = 0 &&DROPHASDATA_NOTUSEFUL
ENDCASE
CASE nState == 1 && Drag Leave
CASE nState == 2 && Drag Over
ENDCASE
ENDPROC
PROCEDURE edit1.OLEDragDrop
LPARAMETERS oDataObject, nEffect, nButton, nShift, nXCoord, nYCoord
LOCAL i, cText, cNewStr
If oDataObject.Getformat(1) &&CF_TEXT
cText = oDataObject.GetData(1)
This.Value =cText
endif
if oDataObject.GetFormat(15) && Files CF_DROP one file dropped only (all if listbox) (from explorer here)
DIMENSION aValues[1]
oDataObject.GetData(15, @aValues )
*-- Add each filename as a new item in the list
FOR i = 1 to 1 &&alen(aValues) if listbox
This.value=(aValues[m.i])
NEXT
ENDi
NODEFAULT
ENDPROC
PROCEDURE edit1.RightClick
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
Define Bar _Med_cut Of raccourci Prompt "\<Couper" ;
KEY CTRL+x, "Ctrl+X" ;
MESSAGE "Enlève la sélection et la place dans le Presse-papiers"
Define Bar _Med_copy Of raccourci Prompt "Co\<pier" ;
KEY CTRL+C, "Ctrl+C" ;
MESSAGE "Copie la sélection et la place dans le Presse-papiers"
Define Bar _Med_paste Of raccourci Prompt "C\<oller" ;
KEY CTRL+V, "Ctrl+V" ;
MESSAGE "Place le contenu du Presse-papiers au point d'insertion"
Define Bar _Med_find Of raccourci Prompt "Rec\<hercher..." ;
KEY CTRL+F, "Ctrl+F" ;
MESSAGE "Recherche le texte spécifié"
Define Bar _Med_slcta Of raccourci Prompt "Sélec\<tionner tout" ;
KEY CTRL+A, "Ctrl+A" ;
MESSAGE "Sélectionne tout le texte ou tous les éléments de la fenêtre active"
Define Bar _Med_redo Of raccourci Prompt "\<Rétablir" ;
KEY CTRL+R, "Ctrl+R" ;
MESSAGE "Rétablit la dernière opération annulée"
Define Bar _Med_undo Of raccourci Prompt "\<Annuler" ;
KEY CTRL+Z, "Ctrl+Z" ;
MESSAGE "Annule la dernière modification"
Activate Popup raccourci
ENDPROC
PROCEDURE image2.Click
local m.myvar
text to m.myvar pretext 7 noshow
can execute ie (complet interface), ie application,firefox, chrome (if exits on system) or windows explorer
form these windows can oledragdeop text (editbox,textbox) or pictures(warning thre is some links whose are not
picture but mask a navigation to a picture)
if picture:
- on textbox or editbox (retrieve the link picture as text)
-on the image it retrive the real image (if link is real picture or blob picture)
if text oledragged from the fired application , its copied in textbox (one line) or in editbox (multiline).
added a contextuel menu to ths editbox.
for IE11,must in internet options uncheck the protected mode otyherwise no oledragdrop
(ie11/menu/tools/internet options/security tab: unchecjk protectd mode).
or run separatly IE11 as administrator
for firefox,chrome,explorer: no problem.
Right click on the image control to save the picture in images folder created in code (save pictureVAl blob as picture
or picture converted to pictureval from explorer).
endtext
messagebox(m.myvar,0+32+4096,"Summary help")
ENDPROC
ENDDEFINE
*
*-- EndDefine: yoleDD5
Important:All Codes above are tested on VFP9SP2 & windows 10 pro.
Please come back with any bug.correcting code is usefull to all readers.