Working with form regions and transparency part 2
these code continue the previous post working with forms rgions ans transparencies. the first code *1* -draw some pre defined windows small images on desktop (note that drawings are not persistent). -draw bmp's images on desktop (bmp is supported by API loadImage) -can draw on any window given with its handle HWND (0=dsktop,getactivewindow or getfocus for any other window yc VFP main window (_screen.hwnd) or form (thisform.hwnd) -the drawing is made persistent with a timer drawing the image each second. -can position the drawing by the 2 spinners. -can zoom the drawing 1-7 on the spinner -clear button clears the drawing. -the code hide/show all desktop icons(switch from state to another). -can interact dynamically with the form.control to build image on desktop (timer re drawing systematically this bitmap with new parameters). -Adapted :all credits to from http://www.news2news.com/vfp/index.php?example=293 the second code -adapted from news2news for a part-http://www.news2news.com/vfp/index.php?example=144 -clip path with text and fontname/fontsize and revert clip text. -rightclick to fire a contextuel menu for all operations. -can change image background,create a random gradient background,clip/restore form,change fontanem/fontsize & big fontsize (getfont limited to fontsize=72px= -(can add fontstyle in code) -drag the form or clipped text by mousedown anywhere on area. [post 262]
Click on code to select [then copy] -click outside to deselect
*1* created on thursday 15 of february 2018
*draw some pre defined windows small images on desktop (note that drawings are not persistent).
*draw bmp's images on desktop (bmp is supported by API loadImage)
*can draw on any window given with its handle HWND (0=dsktop,getactivewindow or getfocus for any other window yc VFP main window (_screen.hwnd) or form (thisform.hwnd)
*the drawing is made persistent with a timer drawing the image each second.
*can position the drawing by the 2 spinners.
*can zoom the drawing 1-7 on the spinner
*clear button clears the drawing.
*the code hide/show all desktop icons(switch from state to another).
*can interact dynamically with the form.control to build image on desktop (timer re drawing systematically this bitmap with new parameters).
*Adapted :all credits to from http://www.news2news.com/vfp/index.php?example=293
*minimize all apps on desktop
*local oshell
*oshell=newObject("shell.application")
*oshell.MinimizeAll() &&UndoMinimizeALL() for restoring all apps on desktop
*oshell=null
Clea All
Do ydeclare
Inke(1)
*hide desktop icons
#Define WM_COMMAND 0x0111
hWindow = FindWindowEx(0, 0, "Progman", 0)
hWindow = FindWindowEx(hWindow, 0, "SHELLDLL_DefView", 0)
SendMessage(hWindow, WM_COMMAND, 0x7402,0)
With _Screen
.WindowState=1
.AddProperty("xalpha",255)
.AddProperty("fzoom",3) &&zoom factor 1,2,...
.AddProperty("loBitmap","")
.AddProperty("x0",Sysmetric(1)/2)
.AddProperty("y0",10)
Endwith
Public objForm
objForm = Createobject("Tform")
objForm.Show &&Visible = .T.
Read Events
Retu
Define Class Tform As Form
Caption = "Drawing Windows predefined bitmaps"
Width=360
Height=150
Left=10
Top=350
ShowWindow=2
AlwaysOnTop=.T.
MaxButton=.F.
BorderStyle=0
ShowTips=.T.
Name="Tform"
Add Object combo1 As ComboBox With;
Left=15, Top=15, Width=230, Style=2, ColumnCount=2,;
BoundColumn=2, ColumnWidths="160,60"
Add Object spinner1 As Spinner With Top=15,Left=250,Width=60,Value=255,SpinnerLowValue=128,SpinnerHighValue=255,KeyboardLowValue=0,KeyboardHighValue=255,ToolTipText="opacity"
Add Object spinner2 As Spinner With Top=15,Left=312,Width=45,Value=3,SpinnerLowValue=1,SpinnerHighValue=10,KeyboardLowValue=1,KeyboardHighValue=10,ToolTipText="Zoom factor"
Add Object lbl1 As Label With;
Left=15, Top=Thisform.Height-80, Width=250,;
Height=50, WordWrap=.T., BackStyle=0,;
Caption="Select predefined bitmap to display it " +;
"on the main VFP window"
Add Object command1 As CommandButton With Caption="img",AutoSize=.T.,MousePointer=15,Left=290,Top=Thisform.Height-80
Add Object yshp As Shape With Left=340 ,Top=Thisform.Height-75 ,Width=15,Height=15,Curvature=99,BackColor=255,BorderColor=255
Add Object command2 As CommandButton With Caption="clear",AutoSize=.T.,MousePointer=15,Left=290,Top=Thisform.Height-40
Add Object timer1 As Timer With Enabled=.F.,Interval=1000,Name="timer1"
Add Object spinnerX As Spinner With Top=Thisform.Height-40 ,Left=10,Width=60,Value=0,SpinnerLowValue=-Sysmetric(1)/2,SpinnerHighValue=Sysmetric(1)/2,KeyboardLowValue=-Sysmetric(1)/2,KeyboardHighValue=Sysmetric(1)/2,ToolTipText="X"
Add Object spinnerY As Spinner With Top=Thisform.Height-40 ,Left=75,Width=60,Value=0,SpinnerLowValue=-Sysmetric(1)/2,SpinnerHighValue=Sysmetric(1)/2,KeyboardLowValue=-Sysmetric(1)/2,KeyboardHighValue=Sysmetric(1)/2,ToolTipText="Y"
Procedure spinnerX.InteractiveChange
=InvalidateRect(0, 0, .F.)
Endproc
Procedure spinnerY.InteractiveChange
=InvalidateRect(0, 0, .F.)
Endproc
Procedure timer1.Timer
#Define LR_LOADFROMFILE 16
LoadAndShowBitmap(_Screen.loBitmap, LR_LOADFROMFILE,_Screen.x0+Thisform.spinnerX.Value,_Screen.y0+Thisform.spinnerY.Value)
Rand(-1)
Thisform.yshp.BackColor=Rgb(255*Rand(),255*Rand(),255*Rand())
Endproc
Procedure command2.Click
Thisform.timer1.Enabled=.F.
=InvalidateRect(0, 0, .F.)
Endproc
Procedure spinner1.InteractiveChange
=InvalidateRect(0, 0, .F.)
_Screen.xalpha=This.Value
Endproc
Procedure spinner2.InteractiveChange
=InvalidateRect(0, 0, .F.)
_Screen.fzoom=This.Value
Endproc
Procedure command1.Click
#Define LR_LOADFROMFILE 16
#Define AC_SRC_OVER 0
#Define AC_SRC_ALPHA 1
#Define AC_SRC_NO_ALPHA 2
#Define IMAGE_BITMAP 0
#Define SRCCOPY 0xCC0020
#Define BITMAP_STRU_SIZE 24
Local lcBitmap
*lcBitmap = "C:\WinNT\system32\setup.bmp"
lcBitmap = Getpict('bmp')
If Empty(lcBitmap) Or Lower(Justext(lcBitmap))<>"bmp" &&loadimage api support only bmp's
Return .F.
Endi
_Screen.loBitmap=m.lcBitmap
Thisform.timer1.Enabled=.T.
= LoadAndShowBitmap(_Screen.loBitmap, LR_LOADFROMFILE,_Screen.x0+Thisform.spinnerX.Value,_Screen.y0+Thisform.spinnerY.Value)
Endproc
Procedure Init
With This.combo1
.ListIndex = 1
.InteractiveChange
Endwith
Endproc
Procedure combo1.InteractiveChange
Local lnBitmapType, hBitmap
lnBitmapType = Val(This.Value)
hBitmap = LoadBitmap(0, lnBitmapType)
If hBitmap <> 0
thisform.command2.click &&clear previous drawing
inke(0.4,"H")
= ShowBitmap (hBitmap, _Screen.x0,_Screen.y0)
= DeleteObject(hBitmap)
Endif
Endproc
Procedure combo1.Init && windows pre defined small images
with this
.NewItem ("OBM_BTNCORNERS", 32758)
.NewItem ("OBM_BTSIZE", 32761)
.NewItem ("OBM_CHECK", 32760)
.NewItem ("OBM_CHECKBOXES", 32759)
.NewItem ("OBM_CLOSE", 32754)
.NewItem ("OBM_COMBO", 32738)
.NewItem ("OBM_DNARROW", 32752)
.NewItem ("OBM_DNARROWD", 32742)
.NewItem ("OBM_DNARROWI", 32736)
.NewItem ("OBM_LFARROW", 32750)
.NewItem ("OBM_LFARROWD", 32740)
.NewItem ("OBM_LFARROWI", 32734)
.NewItem ("OBM_MNARROW", 32739)
.NewItem ("OBM_OLD_CLOSE", 32767)
.NewItem ("OBM_OLD_DNARROW", 32764)
.NewItem ("OBM_OLD_LFARROW", 32762)
.NewItem ("OBM_OLD_REDUCE", 32757)
.NewItem ("OBM_OLD_RESTORE", 32755)
.NewItem ("OBM_OLD_RGARROW", 32763)
.NewItem ("OBM_OLD_UPARROW", 32765)
.NewItem ("OBM_OLD_ZOOM", 32756)
.NewItem ("OBM_REDUCE", 32749)
.NewItem ("OBM_REDUCED", 32746)
.NewItem ("OBM_RESTORE", 32747)
.NewItem ("OBM_RESTORED", 32744)
.NewItem ("OBM_RGARROW", 32751)
.NewItem ("OBM_RGARROWD", 32741)
.NewItem ("OBM_RGARROWI", 32735)
.NewItem ("OBM_SIZE", 32766)
.NewItem ("OBM_UPARROW", 32753)
.NewItem ("OBM_UPARROWD", 32743)
.NewItem ("OBM_UPARROWI", 32737)
.NewItem ("OBM_ZOOM", 32748)
.NewItem ("OBM_ZOOMD", 32745)
endwith
Protected Procedure combo1.NewItem(lcName, lnValue)
This.AddItem(lcName)
This.List(This.ListCount, 2) = Str(lnValue)
Endproc
Procedure Destroy
*show desktop icons
#Define WM_COMMAND 0x0111
hWindow = FindWindowEx(0, 0, "Progman", 0)
hWindow = FindWindowEx(hWindow, 0, "SHELLDLL_DefView", 0)
SendMessage(hWindow, WM_COMMAND, 0x7402,1)
*clean references
With _Screen
.xalpha=Null
.fzoom=Null
.loBitmap=Null
.x0=Null
.y0=Null
clea dlls
Endwith
Local oshell
oshell=Newobject("shell.application")
oshell.UndoMinimizeALL() && for restoring all apps presents initially on desktop
oshell=Null
Clea Events
Endproc
Enddefine
* --------------------------------------------------------------
Procedure ShowBitmap (hBitmap, lnX, lnY)
* #Define SRCCOPY 13369376
* a little break needed for the VFP to properly react
= Inkey(0.5)
Local HWnd, hDC, hMemDC, lnWidth, lnHeight
Store 0 To lnWidth, lnHeight
= GetBitmapSize (hBitmap, @lnWidth, @lnHeight)
HWnd = 0 &&GetActiveWindow() &&draw on desktop here (drawing not persistent,nedd a call back with process function..)
hDC = GetWindowDC (HWnd)
hMemDC = CreateCompatibleDC(hDC)
= SelectObject (hMemDC, hBitmap)
= BitBlt (hDC, lnX,lnY, lnWidth,lnHeight,;
hMemDC, 0,0, SRCCOPY)
= DeleteDC(hMemDC)
= ReleaseDC (HWnd, hDC)
Endproc
Function GetBitmapSize (hBitmap, lnWidth, lnHeight)
* #Define BITMAP_STRU_SIZE 24
Local lcBuffer
lcBuffer = Repli(Chr(0), BITMAP_STRU_SIZE)
If GetObjectA(hBitmap, BITMAP_STRU_SIZE, @lcBuffer) <> 0
lnWidth = buf2dword (Substr(lcBuffer, 5,4))
lnHeight = buf2dword (Substr(lcBuffer, 9,4))
Endif
Endfunc
Procedure LoadAndShowBitmap(lcBitmap, lnLoadOptions, lnX,lnY)
Local hBitmap
hBitmap = LoadImage(0, lcBitmap, IMAGE_BITMAP,0,0, lnLoadOptions)
If hBitmap <> 0
= ShowBitmap(hBitmap, lnX,lnY)
= DeleteObject(hBitmap)
Else
= Messagebox(lcBitmap + Chr(13) + Chr(13) +;
"Check if this is a valid bitmap file.",;
32, " Unable to load an image from file")
Endif
Endproc
Procedure ShowBitmap(hBitmap, lnX, lnY)
*|typedef struct _BLENDFUNCTION {
*| BYTE BlendOp;
*| BYTE BlendFlags;
*| BYTE SourceConstantAlpha;
*| BYTE AlphaFormat;
*|}BLENDFUNCTION, *PBLENDFUNCTION, *LPBLENDFUNCTION;
Local hWindow, hDC, hMemDC, lnWidth, lnHeight
Store 0 To lnWidth, lnHeight
= GetBitmapSize(hBitmap, @lnWidth, @lnHeight)
hWindow = 0 &&desktop &&GetActiveWindow()
hDC = GetWindowDC(hWindow)
hMemDC = CreateCompatibleDC(hDC)
= SelectObject(hMemDC, hBitmap)
Local lnAlphaBlend, lnResult,;
lnBlendOp, lnBlendFlags, lnSrcConstAlpha, lnAlphaFormat
lnBlendOp = AC_SRC_OVER && always
lnBlendFlags = 0 && always
lnSrcConstAlpha = _Screen.xalpha && opacity 0-255
lnAlphaFormat = 0 && try AC_SRC_ALPHA on non-white background
* assembling the BLENDFUNCTION structure
lnAlphaBlend = lnBlendOp +;
BitLShift(lnBlendFlags, 8) +;
BitLShift(lnSrcConstAlpha, 16) +;
BitLShift(lnAlphaFormat, 24)
lnResult = AlphaBlend(hDC, lnX,lnY,_Screen.fzoom*lnWidth,_Screen.fzoom*lnHeight,;
hMemDC, 0,0, lnWidth,lnHeight,;
lnAlphaBlend)
If lnResult = 0
* 6 = The handle is invalid
* 87 = The parameter is incorrect
? "Error:", GetLastError()
Endif
= DeleteDC(hMemDC)
= ReleaseDC(hWindow, hDC)
Return .T.
Endproc
Function GetBitmapSize(hBitmap, lnWidth, lnHeight)
Local lcBuffer
lcBuffer = Repli(Chr(0), BITMAP_STRU_SIZE)
If GetObjectA(hBitmap, BITMAP_STRU_SIZE, @lcBuffer) <> 0
lnWidth = buf2dword(Substr(lcBuffer, 5,4))
lnHeight = buf2dword(Substr(lcBuffer, 9,4))
Endif
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
Procedure ydeclare
Declare Integer LoadBitmap In user32 Integer hInstance, Integer lpBitmapName
Declare Integer CreateCompatibleDC In gdi32 Integer hdc
Declare Integer DeleteDC In gdi32 Integer hdc
Declare Integer ReleaseDC In user32 Integer HWnd, Integer dc
Declare Integer GetActiveWindow In user32
Declare Integer GetWindowDC In user32 Integer HWnd
Declare Integer DeleteObject In gdi32 Integer hObject
Declare Integer SelectObject In gdi32 Integer hdc, Integer hObject
DECLARE INTEGER GetObject IN gdi32;
AS GetObjectA;
INTEGER hgdiobj,;
INTEGER cbBuffer,;
STRING @ lpvObject
Declare Integer BitBlt In gdi32;
INTEGER hDestDC, Integer x, Integer Y,;
INTEGER nWidth, Integer nHeight, Integer hSrcDC,;
INTEGER xSrc, Integer ySrc, Integer dwRop
Declare Integer LoadImage In user32;
INTEGER hinst, String lpszName, Integer uType,;
INTEGER cxDesired, Integer cyDesired, Integer fuLoad
Declare Integer AlphaBlend In Msimg32;
INTEGER hDestDC, Integer x, Integer Y,;
INTEGER nWidth, Integer nHeight, Integer hSrcDC,;
INTEGER xSrc, Integer ySrc, Integer nWidthSrc,;
INTEGER nHeightSrc, Integer blendFunction
Declare Integer GetLastError In kernel32
Declare Integer InvalidateRect In user32 Integer HWnd , Integer lpRect , Integer bErase
Declare Integer FindWindowEx In user32;
INTEGER hwndParent,;
INTEGER hwndChildAfter,;
STRING @ lpszClass,;
STRING @ lpszWindow
Declare Integer SendMessage In user32;
INTEGER HWnd,;
INTEGER Msg,;
INTEGER wParam,;
INTEGER Lparam
Endproc
two right images are drawn directly on desktop.
Click on code to select [then copy] -click outside to deselect
*2* created on thursday 15 of february 2016 - updated on 17 with a built linear gradient image built with Apis
*adapted from news2news for a part-http://www.news2news.com/vfp/index.php?example=144
*clip path with text and fontname/fontsize and revert clip text.
*rightclick to fire a contextuel menu for all operations.
*can change image background,create a random gradient background,clip/restore form,change fontanem/fontsize & big fontsize (getfont limited to fontsize=72px=
*(can add fontstyle in code)
*drag the form or clipped text by mousedown anywhere on area.
*!*toggle all desktop apps
*!* local oshell
*!* oshell=newObject("shell.application")
*!* oshell.toggleDesktop()
*!* oshell=null
*!* inke(1)
Set Defa To( Justpath(Sys(16)))
With _Screen
.AddProperty("xfontname","Impact")
.AddProperty("xfontsize",150)
.WindowState=1
Endwith
Do ydeclare
Inke(1)
*hide desktop icons
#Define WM_COMMAND 0x0111
hWindow = FindWindowEx(0, 0, "Progman", 0)
hWindow = FindWindowEx(hWindow, 0, "SHELLDLL_DefView", 0)
SendMessage(hWindow, WM_COMMAND, 0x7402,0)
Public oform
oform = Createobject("yform")
oform.Show
Read Events
Retu
Define Class yform As Form
Width=Sysmetric(1)
Height=250
Caption="Working with GDI Path and Region-Rightclick for menu."
BackColor=Rgb(212,208,210)
BorderStyle=2
AutoCenter =.T.
ShowWindow=2
MaxButton=.F.
BackColor = Rgb (192,192,192)
hFontHeader=0
hFontMemo=0
Add Object image1 As Image With Anchor=15,Left=0,Top=0,Width=Thisform.Width,Height=Thisform.Height,Stretch=2,Picture="",Visible=.F.
Add Object ybkg As CommandButton With Left=-100,Top=This.Height-60,Width=100,Height=25,Caption="Img Background",Style=1
Add Object ybkgrad As CommandButton With Left=-115,Top=This.Height-60,Width=130,Height=25,Caption="Gradient Background",Style=1
Add Object txt As TextBox With;
Left=10, Top=This.Height-35, Width=240,;
Height=25, Value="Foxpro lovers"
Add Object cmdClip As CommandButton With;
Top=This.txt.Top, Left=This.txt.Left+This.txt.Width+5,;
Height=This.txt.Height, Width=50,;
Default=.T., Caption="Clip",Style=1
Add Object chkMode As Checkbox With;
Top=This.txt.Top, Left=-150,;
Backstyle=0, AutoSize=.T., Caption="Invert", Value=.F.,Visible=.F.
Procedure Init
This.SetAll("mousepointer",15,"commandbutton")
This.createFont (_Screen.xfontname,_Screen.xfontsize)
Endproc
Procedure Activate
Thisform.ymenu()
Endproc
Procedure ybkg.Click
Local m.xpict
m.xpict=Getpict()
If Empty(m.xpict)
Return .F.
Endi
With This.Parent.image1
.Picture=m.xpict
.Left=0
.Top=0
.Width=.Parent.Width
.Height=.Parent.Height
.ZOrder(1)
.Visible=.T.
Endwith
Endproc
Procedure ybkgrad.Click
Local m.lnHeight,m.lnWidth
m.lnWidth=Thisform.Width
m.lnHeight=Thisform.Height
With Thisform
.image1.Visible=.F.
Rand(-1)
red=255*Rand()
green=255*Rand()
blue=255*Rand()
For i = 0 To m.lnHeight
.ForeColor = Rgb (red,green,255-i * blue/m.lnHeight)
.Line (0, i, lnWidth, i)
Endfor
Endwith
Endproc
Procedure RightClick
Thisform.ymenu()
Endproc
Procedure image1.RightClick
Thisform.ymenu()
Endproc
Procedure KeyPress
Lparameters nKeyCode, nShiftAltCtrl
If nKeyCode=27
Thisform.Release
Endi
Endproc
Procedure cmdClip.Click
Thisform.clipText
Endproc
Procedure ymenu
Define Popup raccourci SHORTCUT Relative From Mrow(),Mcol()
Define Bar 1 Of raccourci Prompt "clip"
Define Bar 2 Of raccourci Prompt "invert"
Define Bar 3 Of raccourci Prompt "Image Background"
Define Bar 4 Of raccourci Prompt "gradient background"
Define Bar 5 Of raccourci Prompt "restore form"
Define Bar 6 Of raccourci Prompt "Select font"
Define Bar 7 Of raccourci Prompt "Select big fontsize"
Define Bar 8 Of raccourci Prompt "Image gradient"
Define Bar 9 Of raccourci Prompt "Exit"
On Selection Bar 1 Of raccourci _Screen.ActiveForm.clipText
On Selection Bar 2 Of raccourci _Screen.ActiveForm.chkMode.InteractiveChange()
On Selection Bar 3 Of raccourci _Screen.ActiveForm.ybkg.Click
On Selection Bar 4 Of raccourci _Screen.ActiveForm.ybkgrad.Click
On Selection Bar 5 Of raccourci _Screen.ActiveForm.removeRegion
On Selection Bar 6 Of raccourci _Screen.ActiveForm.yfont()
On Selection Bar 7 Of raccourci _Screen.ActiveForm.yfontsize()
On Selection Bar 8 Of raccourci _Screen.ActiveForm.yGenerateGradBitmap()
On Selection Bar 9 Of raccourci _Screen.ActiveForm.Release
Activate Popup raccourci
Endproc
Procedure chkMode.InteractiveChange
This.Value=!This.Value
Thisform.clipText
Endproc
Procedure yfont()
Local m.x
m.x=Getfont(_Screen.xfontname)
If Empty(m.x)
Return .F.
Endi
xfontname=Getwordnum(m.x,1,',')
xfontsize=Int(Val(Getwordnum(m.x,2,',')))
_Screen.xfontsize=m.xfontsize
If _Screen.xfontsize<72 && to avoid small fontsize .
_Screen.xfontsize=72
Endi
_Screen.xfontname=xfontname
Thisform.createFont(_Screen.xfontname,_Screen.xfontsize)
Endproc
Procedure yfontsize
Local m.x
m.x=Int(Val(Inputbox("Select a fontsize","",Trans(_Screen.xfontsize))))
If m.x=0
Return .F.
Endi
_Screen.xfontsize=m.x
Thisform.createFont(_Screen.xfontname,_Screen.xfontsize)
Endproc
Procedure createFont
Lparameters xfontname,xfontsize
#Define FW_BOLD 700
#Define FW_NORMAL 400
#Define ANSI_CHARSET 0
#Define OUT_OUTLINE_PRECIS 8
#Define CLIP_STROKE_PRECIS 2
#Define PROOF_QUALITY 2
#Define DEFAULT_PITCH 0
This.hFontHeader = createFont (;
xfontsize,0, 0,0, FW_BOLD, 0,0,0, ANSI_CHARSET,;
OUT_OUTLINE_PRECIS, CLIP_STROKE_PRECIS,;
PROOF_QUALITY, DEFAULT_PITCH, xfontname)
Thisform.clipText
Endproc
Procedure releaseFont
= DeleteObject (This.hFontMemo)
= DeleteObject (This.hFontHeader)
Endproc
Procedure clipText
#Define TRANSPARENT 1
#Define OPAQUE 2
#Define RGN_COPY 5
Local lcText, HWnd, hdc, hStoredFont
HWnd = GetFocus()
hdc = GetWindowDC (HWnd)
= BeginPath (hdc)
hStoredFont = SelectObject (hdc, This.hFontHeader)
= SetBkMode (hdc, Iif(Thisform.chkMode.Value, OPAQUE,TRANSPARENT))
This._print (hdc, 15,25, " "+Alltrim(This.txt.Value)+" ")
= EndPath (hdc)
hRgn = PathToRegion (hdc)
= SetWindowRgn (HWnd, hRgn, 1)
= SelectObject (hdc, hStoredFont)
= ReleaseDC (HWnd, hdc)
Endproc
Procedure _print (hdc, x,Y, lcText)
= TextOut (hdc, x,Y, lcText, Len(lcText))
Endproc
Procedure removeRegion
Local HWnd
HWnd =Thisform.HWnd &&GetFocus()
= SetWindowRgn (HWnd, 0, 1)
Endproc
Procedure MouseDown && move form [can be set on any object even of form. )
Lparameters nButton, nShift, nXCoord, nYCoord
Thisform.MousePointer=15
lnHandle0=Thisform.HWnd
param1 = 274
param2 = 0xF012
bb=ReleaseCapture()
bb=SendMessage(lnHandle0, param1, param2,0)
Thisform.MousePointer=0
Endproc
Procedure image1.MouseDown
Lparameters nButton, nShift, nXCoord, nYCoord
Thisform.MouseDown(1)
Endproc
Procedure yGenerateGradBitmap()
Local m.xcolor1,m.xcolor2,m.xmode
m.xcolor1=Getcolor()
m.xcolor2=Getcolor()
m.xmode=int(val(inputbox("Modes:0,1,2,3","","2")))
if !inlist(m.xmode,0,1,2,3)
m.xmode=2
endi
=yGenerateGradBitmap(xcolor1,xcolor2,2) &&xcolor1,xcolor2,xmode
If !File("ygrad.jpg")
Return .F.
Endi
With Thisform.image1
.Picture="ygrad.jpg"
.Left=0
.Top=0
.Width=.Parent.Width
.Height=.Parent.Height
.ZOrder(1)
.Visible=.T.
Endwith
Endproc
Procedure Destroy
*hide desktop icons
#Define WM_COMMAND 0x0111
hWindow = FindWindowEx(0, 0, "Progman", 0)
hWindow = FindWindowEx(hWindow, 0, "SHELLDLL_DefView", 0)
SendMessage(hWindow, WM_COMMAND, 0x7402,0)
This.releaseFont
_Screen.xfontname=Null
Release _Screen.xfontanme
_Screen.xfontsize=Null
Release _Screen.xfontsize
erase ygrad.jpg
Clea Events
Endproc
Enddefine
Procedure ydeclare
Declare Integer GetWindowDC In user32 Integer HWnd
Declare Integer GetFocus In user32
Declare Integer ReleaseDC In user32;
INTEGER HWnd, Integer hdc
Declare Integer SelectObject In gdi32;
INTEGER hdc, Integer hObject
Declare Integer DeleteObject In gdi32 Integer hObject
Declare Integer SetBkMode In gdi32;
INTEGER hdc, Integer iBkMode
Declare Integer TextOut In gdi32;
INTEGER hdc, Integer x, Integer Y,;
STRING lpString, Integer nCount
Declare Integer CreateFont In gdi32;
INTEGER nHeight, Integer nWidth,;
INTEGER nEscapement, Integer nOrientation,;
INTEGER fnWeight, Integer fdwItalic,;
INTEGER fdwUnderline, Integer fdwStrikeOut,;
INTEGER fdwCharSet,;
INTEGER fdwOutputPrecision,;
INTEGER fdwClipPrecision,;
INTEGER fdwQuality,;
INTEGER fdwPitchAndFamily,;
STRING lpszFace
Declare Integer BeginPath In gdi32 Integer hdc
Declare Integer EndPath In gdi32 Integer hdc
Declare Integer PathToRegion In gdi32 Integer hdc
Declare SetWindowRgn In user32;
INTEGER HWnd, Integer hRgn, Integer bRedraw
Declare Integer GetCursorPos In user32 String @ lpPoint
Declare Integer ReleaseCapture In WIN32API
Declare Integer FindWindowEx In user32;
INTEGER hwndParent,;
INTEGER hwndChildAfter,;
STRING @ lpszClass,;
STRING @ lpszWindow
Declare Integer SendMessage In user32;
INTEGER HWnd,;
INTEGER Msg,;
INTEGER wParam,;
INTEGER Lparam
Endproc
***********
Function yGenerateGradBitmap
*create a jpg picture wihh gradient 2 colors (GdipCreateLineBrushFromRectI)
Lparameters xcolor1,xcolor2,xmode
If Empty(m.xcolor1) Or Empty(m.xcolor2)
Return .F.
Endi
If Empty(xmode) Or !Inlist(xmode,0,1,2,3)
xmode=0
Endi
#Define PixelFormat 0x00022009
*#DEFINE BMPClsID 0h00F47C55041AD3119A730000F81EF32E &&bmp format
#Define JPEGClsId 0h01F47C55041AD3119A730000F81EF32E &&JPGFormat
Declare Long GdipCreateLineBrushFromRectI In GDIPlus.Dll ;
String Rect, Long Color1, Long Color2, Long Mode, ;
Long WrapModeTile, Long @ brush
Declare Long GdipDeleteBrush In GDIPlus.Dll Long brush
Declare Long GdipFillRectangleI In GDIPlus.Dll ;
Long Bitmap, Long brush, Long x, Long Y, Long Width, Long Height
Declare Long GdipCreateBitmapFromScan0 In GDIPlus.Dll ;
Long Width, Long Height, Long stride, Long Format, Long scan0, Long @ Bitmap
Declare Long GdipSaveImageToFile In GDIPlus.Dll Long nativeImage, ;
String cUnicodeFileName, String ClsidEncoder, String EncoderParameters
Declare Long GdipDisposeImage In GDIPlus.Dll Long Bitmap
Declare Long GdipDeleteGraphics In GDIPlus.Dll Long graphics
Declare Long GdipGetImageGraphicsContext In GDIPlus.Dll Long Bitmap, Long @ graphics
Local lnWidth, lnHeight, lnBrushWidth, lnBrushHeight, lnStartColor, lnEndColor
Local lnMode, lnWrapModeTile, lcOutFile, lnBitMap, lnGraphics, lnBrush, lcRect
Local lnStat &&, lcPath
Clea Resources("ygrad.jpg")
If File("ygrad.jpg")
Erase "ygrad.jpg"
Endi
lnWidth = 200 && image width
lnHeight = 150 && image height
lnBrushWidth = 200 && brush width
lnBrushHeight = 150 && brush height
lnStartColor =rgb2html(xcolor1) &&0xFFEE0000 && initial grad color
lnEndColor =rgb2html(xcolor2) &&0xFF0000EE && end grad color
lnMode = xmode && 0 à 3, interpolation color mode
lnWrapModeTile = 0 && 0 à 3, color transition color type
lcOutFile = "ygrad.jpg"
*
* create the bitmap*
lnBitMap = 0
lnStat = GdipCreateBitmapFromScan0(lnWidth, lnHeight, 0, PixelFormat, 0, @lnBitMap)
If lnStat = 0
*
* creat graphic object associated with the bitmap *
lnGraphics = 0
lnStat = GdipGetImageGraphicsContext(lnBitMap, @lnGraphics)
Endif
If lnStat = 0
*
* create brush structure
* lnBrush = 0
lcRect = BinToC(0, "4RS") + ; && X
BinToC(0, "4RS") + ; && Y
BinToC(lnBrushWidth, "4RS") + ; && with
BinToC(lnBrushHeight, "4RS") && Height
lnStat = GdipCreateLineBrushFromRectI(lcRect, lnStartColor, lnEndColor,lnMode, lnWrapModeTile, @lnBrush)
Endif
If lnStat = 0
*
* draw rectangular zone on the graphic *
lnStat = GdipFillRectangleI(lnGraphics, lnBrush, 0, 0, lnWidth, lnHeight)
Endif
If lnStat = 0
*
* save bitmap as JPEG image *
lcOutFile = Strconv(lcOutFile + Chr(0), 5) &&file name in unicode
lnStat = GdipSaveImageToFile(lnBitMap, lcOutFile, JPEGClsId, Null)
Endif
*
*clean object created *
= GdipDeleteBrush(lnBrush)
= GdipDeleteGraphics(lnGraphics)
= GdipDisposeImage(lnBitMap)
*CLEAR DLLS
If lnStat != 0
= Messagebox('error GDI ' + Ltrim(Str(lnStat)))
Else
* run/n explorer ygrad.jpg
Endif
Endfunc
*convert rgb color to special hexa color format 0xAAAAAAAA
Function rgb2html
Lparameters tnColor
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", "" ))
Return Eval(Strtran(loColor.cHTMLcolor,"#","0xFF")) &&FOR THIS use ONLY to retrieve the format 0x******** value
Endfunc
Click on code to select [then copy] -click outside to deselect
*3* created on wednesday 28 of ferbuary 2018
*a form hole 100% transparent with a circular shape moved by mousepointer on form area.
PUBLIC oform
oform=NEWOBJECT("formHole")
oform.Show
read events
RETURN
*
DEFINE CLASS formHole AS form
Top = 0
Left = 0
Height = 552
Width = 1199
Desktop = .T.
ShowWindow = 2
ShowTips = .T.
Caption = "Move the shape by mouseMove on form to see the behind scene in a circle 100% transparent"
WindowState = 2
Name = "form1"
ADD OBJECT image1 AS image WITH ;
Anchor = 15, ;
Stretch = 2, ;
Height = 85, ;
Left = 0, ;
Top = 4, ;
Width = 157, ;
Name = "Image1"
ADD OBJECT shape1 AS shape WITH ;
Top = 72, ;
Left = 240, ;
Height = 204, ;
Width = 276, ;
Curvature = 99, ;
ToolTipText = "Move me on form area please!", ;
BackColor = RGB(255,0,128), ;
mousepointer=15,;
Name = "Shape1"
PROCEDURE yloadimg
lparameters lcUrl
Local loRequest
m.loRequest = Createobject('MsXml2.XmlHttp')
m.loRequest.Open("GET",lcUrl,.F.)
m.loRequest.Send()
return(m.loRequest.ResponseBody )
m.loRequest=Null
ENDPROC
PROCEDURE Load
Declare Integer GetWindowLong In user32;
INTEGER HWnd, Integer nIndex
Declare Integer SetWindowLong In user32;
INTEGER HWnd, Integer nIndex, Integer dwNewLong
Declare Integer SetLayeredWindowAttributes In user32;
INTEGER HWnd, Integer crKey,;
SHORT bAlpha, Integer dwFlags
_screen.windowstate=1
ENDPROC
PROCEDURE Init
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
#Define GWL_EXSTYLE -20
#Define WS_EX_LAYERED 0x80000
Local nExStyle, nRgb, nAlpha, nFlags
yHWnd=Thisform.HWnd
nExStyle = GetWindowLong(yHWnd, GWL_EXSTYLE)
nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
= SetWindowLong(yHWnd, GWL_EXSTYLE, nExStyle)
nRgb = thisform.shape1.backcolor &&the color to make transparent
nAlpha =128
nFlags = LWA_COLORKEY &&+ LWA_ALPHA
= SetLayeredWindowAttributes(yHWnd, m.nRgb,m.nAlpha, m.nFlags)
ENDPROC
procedure activate
with thisform && bug in vfp9 form caption at windowstate=2 (disappears)
.windowstate=0
inke(0.2)
.windowstate=2
endwith
endproc
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE image1.MouseMove
LPARAMETERS nButton, nShift, nXCoord, nYCoord
with thisform.shape1
.left=nxCoord
.top=nyCoord
endwith
ENDPROC
PROCEDURE image1.Init
with this
.left=0
.top=0
.width=.parent.width
.height=.parent.height
.pictureVal=thisform.yloadImg("http://img.over-blog-kiwi.com/1/43/54/07/20180212/ob_804072_kantara.jpg")
.zorder(1)
endwith
ENDPROC
PROCEDURE shape1.Init
this.height=this.width
ENDPROC
ENDDEFINE
*
*-- EndDefine: formHole
Click on code to select [then copy] -click outside to deselect
*4*created on 23 of march 2018
*!* -can lock the form area with a transparent shape (colored or fully transprent)
*!* -select the appropried button and click.all the form controls are locked and inaccessible.
*!* -the form locked dont release also until you unlock it.
*!* -use mouse middleclick here to unlock the form.(can customize).
PUBLIC oform
oform=NEWOBJECT("ylockF")
oform.Show
RETURN
*
DEFINE CLASS ylockF AS form
BorderStyle = 0
Height = 425
Width = 941
ShowWindow = 2
AutoCenter = .T.
Caption = "Lock a form with a transparent shape-middleClick to unlock here."
BackColor = RGB(212,208,210)
ybkg = (rgb(255,145,120))
Name = "Form1"
ADD OBJECT command1 AS commandbutton WITH ;
Top = 24, ;
Left = 48, ;
Height = 37, ;
Width = 109, ;
Caption = "Command1", ;
Name = "Command1"
ADD OBJECT text1 AS textbox WITH ;
Height = 37, ;
Left = 192, ;
Top = 24, ;
Width = 97, ;
Name = "Text1"
ADD OBJECT edit1 AS editbox WITH ;
Height = 180, ;
Left = 56, ;
Top = 84, ;
Width = 241, ;
Name = "Edit1"
ADD OBJECT combo1 AS combobox WITH ;
Height = 37, ;
Left = 348, ;
Top = 24, ;
Width = 97, ;
Name = "Combo1"
ADD OBJECT image1 AS image WITH ;
Height = 240, ;
Left = 315, ;
Top = 84, ;
Width = 289, ;
Name = "Image1"
ADD OBJECT grid1 AS grid WITH ;
Height = 264, ;
Left = 620, ;
Top = 84, ;
Width = 312, ;
Name = "Grid1"
ADD OBJECT command2 AS commandbutton WITH ;
Top = 390, ;
Left = 372, ;
Height = 27, ;
Width = 84, ;
Caption = "Lock1", ;
Name = "Command2"
ADD OBJECT label1 AS label WITH ;
Caption = "Label1", ;
Height = 25, ;
Left = 480, ;
Top = 24, ;
Width = 193, ;
Name = "Label1"
ADD OBJECT command3 AS commandbutton WITH ;
Top = 390, ;
Left = 498, ;
Height = 27, ;
Width = 84, ;
Caption = "Lock2", ;
Name = "Command3"
ADD OBJECT shape1 AS shape WITH ;
Top = 380, ;
Left = 612, ;
Height = 37, ;
Width = 49, ;
Curvature = 30, ;
BackColor = RGB(235,255,215), ;
Name = "Shape1"
ADD OBJECT shape2 AS shape WITH ;
Top = 380, ;
Left = 674, ;
Height = 37, ;
Width = 49, ;
Curvature = 30, ;
BackColor = RGB(255,225,210), ;
Name = "Shape2"
ADD OBJECT shape3 AS shape WITH ;
Top = 380, ;
Left = 740, ;
Height = 37, ;
Width = 49, ;
Curvature = 30, ;
BackColor = RGB(206,206,255), ;
Name = "Shape3"
ADD OBJECT shape4 AS shape WITH ;
Top = 380, ;
Left = 801, ;
Height = 37, ;
Width = 49, ;
Curvature = 30, ;
BackColor = RGB(221,187,255), ;
Name = "Shape4"
PROCEDURE my
thisform.removeObject("yshp") &&mouse middeleclick to unlock form.
ENDPROC
PROCEDURE my0
LPARAMETERS nButton, nShift, nXCoord, nYCoord
if nbutton=1 or nbutton=2
wait window "form locked..." at Mrow(),Mcol() timeout 1
endi
ENDPROC
PROCEDURE QueryUnload
if vartype(thisform.yshp)="O"
nodefault
return .f.
endi
ENDPROC
PROCEDURE Init
thisform.ybkg=thisform.shape1.backcolor
ENDPROC
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE edit1.Init
text to this.value pretext 7 noshow
-can lock the form with a transparent shape (colored or fully transprent)
-select the appropried button and click.all the form controls are locked and inaccessible.
-the form locked dont release also until you unlock it.
-use mouse middleclick here to unlock the form.
endtext
ENDPROC
PROCEDURE grid1.Init
sele * from home(1)+"samples\data\customer" into cursor ycurs
with this
.recordsource="ycurs"
.recordsourcetype=1
.gridlines=0
.deletemark=.f.
.setall("dynamicBackcolor","iif(mod(recno(),2)=0,rgb(140,240,200),rgb(240,240,240))","column")
locate
.refresh
endwith
ENDPROC
PROCEDURE command2.Click
with thisform
try
.addObject("yshp","shape")
catch
endtry
with .yshp
.left=0
.top=0
.width=.parent.width
.height=.parent.height
.backstyle=0
.zorder(0)
.name="yshp"
.visible=.t.
endwith
bindevent(.yshp,"middleclick",thisform,"my")
bindevent(.yshp,"mousedown",thisform,"my0")
endwith
ENDPROC
PROCEDURE command3.Click
with thisform
try
.addObject("yshp","shape")
catch
endtry
with .yshp
.left=0
.top=0
.width=.parent.width
.height=.parent.height
.backstyle=1
.drawmode=9
.backcolor=thisform.ybkg
.zorder(0)
.name="yshp"
.visible=.t.
endwith
bindevent(.yshp,"middleclick",thisform,"my")
bindevent(.yshp,"mousedown",thisform,"my0")
endwith
ENDPROC
PROCEDURE shape1.Click
thisform.ybkg=this.backcolor
ENDPROC
PROCEDURE shape2.Click
thisform.ybkg=this.backcolor
ENDPROC
PROCEDURE shape3.Click
thisform.ybkg=this.backcolor
ENDPROC
PROCEDURE shape4.Click
thisform.ybkg=this.backcolor
ENDPROC
ENDDEFINE
*
*-- EndDefine: yLockF
Click on code to select [then copy] -click outside to deselect
*5* created on23 of march 2018
*!* this code locks the entier desktop (and toogle all apps present on.)
*!* -can press key ESC to unlock and release the top level form (alwaysonTop).
*!* -rightclick to select the form backcolor (semi tranpsrent)
PUBLIC oform
oform=NEWOBJECT("yLockD")
oform.Show
RETURN
*
DEFINE CLASS yLockD AS form
BorderStyle = 0
Top = 0
Left = 0
Height = 635
Width = 1484
ShowWindow = 2
Caption = "Form1"
TitleBar = 1
AlwaysOnTop = .T.
BackColor = RGB(128,0,64)
Name = "Form1"
PROCEDURE Destroy
clea events
ENDPROC
PROCEDURE Load
Declare Integer GetWindowLong In user32;
INTEGER HWnd, Integer nIndex
Declare Integer SetWindowLong In user32;
INTEGER HWnd, Integer nIndex, Integer dwNewLong
Declare Integer SetLayeredWindowAttributes In user32;
INTEGER HWnd, Integer crKey,;
SHORT bAlpha, Integer dwFlags
declare integer BringWindowToTop in user32 integer HWND
_Screen.WindowState=1
ENDPROC
PROCEDURE KeyPress
LPARAMETERS nKeyCode, nShiftAltCtrl
if nkeycode=27 &&can be any key combination to release the form
thisform.release
endi
ENDPROC
PROCEDURE Init
local oshell
oshell=newObject("shell.application")
oshell.ToggleDesktop()
oshell=null
inke(1)
With Thisform
.TitleBar=0
.Left=-5
.Top=-5
.Width=Sysmetric(1)+2*5
.Height=Sysmetric(2)+Sysmetric(9)+Sysmetric(4)+2*5
Endwith
#Define LWA_COLORKEY 1
#Define LWA_ALPHA 2
#Define GWL_EXSTYLE -20
#Define WS_EX_LAYERED 0x80000
Local nExStyle, nRgb, nAlpha, nFlags
yHWnd=Thisform.HWnd
nExStyle = GetWindowLong(yHWnd, GWL_EXSTYLE)
nExStyle = Bitor(nExStyle, WS_EX_LAYERED)
= SetWindowLong(yHWnd, GWL_EXSTYLE, nExStyle)
nRgb =0 && Thisform.BackColor &&the color to make transparent
nAlpha =100
nFlags = LWA_ALPHA +LWA_COLORKEY
= SetLayeredWindowAttributes(yHWnd, m.nRgb,m.nAlpha, m.nFlags)
bringwindowtotop(yhwnd)
ENDPROC
PROCEDURE MouseDown
LPARAMETERS nButton, nShift, nXCoord, nYCoord
wait window "The desktop is locked! press ESC to unlock" at mrow(),mcol() nowait
ENDPROC
PROCEDURE RightClick
local m.x
m.x=getcolor()
if m.x=-1
return .f.
endi
thisform.backcolor=m.x
ENDPROC
ENDDEFINE
*
*-- EndDefine: yLockD
some relative links in this blog
working with form regions and transparency part 1form-transparencies-in-visual-foxpro
working-with-regions-and-apis-in-visual-foxpro
gdiplusx-effects-operations-on-images
free-hand-capturing-as-bitmaps
aero-glass-effect
a-cool-desktop-zones-captures
a-soundplayer-and-radio-player-with-a-basic-wmp
blurring-a-vfp-form-background
a-configurable-desktop-calendar
a-glass-form-as-exciting-windows-effect
blend-2-images-with-gdiplusx
vfp-shapes-and-maps-drawings
|
|
Yousfi Benameur |
Important:All Codes above are tested on VFP9SP2 & windows 10 pro 64 bits version 1709(fall creator) & IE11 emulation. Navigator: firefox - screen:32 pouces.