Working with form regions and transparency part 2

Published on by Yousfi Benameur

       

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.
two right images are drawn directly on desktop.
two right images are drawn directly on desktop.

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



Working with form regions and transparency  part 2
Working with form regions and transparency  part 2
Working with form regions and transparency  part 2
Working with form regions and transparency  part 2
Working with form regions and transparency  part 2
Working with form regions and transparency  part 2

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


Working with form regions and transparency  part 2

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


Working with form regions and transparency  part 2

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



                     

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.

To be informed of the latest articles, subscribe:
Comment on this post