PBMiner

$PBExportHeader$u_canvas.sru
forward
global type u_canvas from userobject
end type
type rect from structure within u_canvas
end type
type paintstruct from structure within u_canvas
end type
end forward

type rect from structure
   long     left
   long     top
   long     right
   long     bottom
end type

type paintstruct from structure
   long     hdc
   boolean     ferase
   rect     rcpaint
   boolean     frestore
   boolean     fincupdate
   character      rgbreserved[32]
end type

global type u_canvas from userobject
integer width = 402
integer height = 200
event wm_paint pbm_paint
event wm_erasebkgnd pbm_erasebkgnd
event type integer onpaint ( longptr hdc )
end type
global u_canvas u_canvas

type prototypes
Protected:

Function Longptr GetModuleHandle( &
   String lpModuleName &
   ) Library "kernel32.dll" Alias For "GetModuleHandleW"

Function Longptr GetProcAddress( &
   Longptr hModule, &
   Longptr lpProcName &
   ) Library "kernel32.dll"

Function Long SetWindowLong32( &
   Longptr hWnd, &
   Integer nIndex, &
   Long dwNewLong &
   ) Library "user32.dll" Alias For "SetWindowLongW"

Function Longptr SetWindowLong64( &
   Longptr hWnd, &
   Integer nIndex, &
   Longptr dwNewLong &
   ) Library "user32.dll" Alias For "SetWindowLongPtrW"

Function Boolean GetClientRect( &
   Longptr hWnd, &
   Ref RECT lpRect &
   ) Library "user32.dll"

Function Boolean InvalidateRect( &
   Longptr hWnd, &
   RECT lpRect, &
   Boolean bErase &
   ) Library "user32.dll"

Function Long BeginPaint( &
   Longptr hwnd, &
   Ref PAINTSTRUCT lpPaint &
   ) Library "user32.dll" Alias For "BeginPaint;Ansi" 

Function Boolean EndPaint( &
   Longptr hwnd, &
   PAINTSTRUCT lpPaint &
   ) Library "user32.dll" Alias For "EndPaint;Ansi" 

Function Longptr CreateCompatibleDC( &
   Longptr hdc &
   ) Library "gdi32.dll"

Function Longptr CreateCompatibleBitmap( &
   Longptr hdc, &
   Integer nWidth, &
   Integer nHeight &
   ) Library "gdi32.dll"

Function Long SelectObject( &
   Longptr hdc, &
   Longptr hgdiobj &
   ) Library "gdi32.dll"

Function Boolean BitBlt( &
   Longptr hdcDest, &
   Integer nXDest, &
   Integer nYDest, &
   Integer nWidth, &
   Integer nHeight, &
   Longptr hdcSrc, &
   Integer nXSrc, &
   Integer nYSrc, &
   Long dwRop &
   ) Library "gdi32.dll"

Function Boolean DeleteDC( &
   Longptr hdc &
   ) Library "gdi32.dll"

Function Boolean DeleteObject( &
   Longptr hObject &
   ) Library "gdi32.dll"

Function Long CreateSolidBrush( &
   Long crColor &
   ) Library "gdi32.dll"

Function Integer FillRect( &
   Longptr hDC, &
   RECT lpRect, &
   Longptr hbr &
   ) Library "user32.dll"

Function ulong GetSystemColor( &
   long nIndex &
   ) Library "user32.dll" Alias For "GetSysColor"

end prototypes

type variables
Private:

Constant Long GWL_WNDPROC = -4
Boolean IsTransparent
Boolean PaintBackground
Integer ProcessBitness
Longptr il_hCanvas
Longptr il_OriginalProc

end variables

forward prototypes
protected subroutine of_settransparent (boolean ab_set)
public function string pbvmname ()
public function long getpbcolor (long al_color)
public subroutine setpaintbackground (boolean ab_set)
private subroutine of_paintbackground (longptr hdc, integer xpbu, integer ypbu, integer wpbu, integer hpbu)
protected subroutine of_paintbackcolor (longptr hdc)
end prototypes

event wm_paint;// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.wm_paint
//
// PURPOSE:    This event is triggered whenever the control needs to be painted.
//
// ARGUMENTS:  hdc - PowerBuilder always passes zero so ignore
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

Constant Long SRCCOPY = 13369376
PAINTSTRUCT ps
RECT rc
Longptr ll_hDC, ll_MemDC, ll_MemBitmap, ll_OrigBitmap

// determine the control size
GetClientRect(il_hCanvas, rc)

// prepare control for painting
ll_hDC = BeginPaint(il_hCanvas, ps)

// set up bitmap buffer
ll_MemDC = CreateCompatibleDC(ll_hDC)
ll_MemBitmap = CreateCompatibleBitmap(ll_hDC, rc.Right, rc.Bottom)
ll_OrigBitmap = SelectObject(ll_MemDC, ll_MemBitmap)

// draw the background
If IsTransparent Then
   If PaintBackground Then
      // use parent to paint background
      Parent.Dynamic of_PaintBackground(ll_MemDC, &
               this.X, this.Y, this.Width, this.Height)
   Else
      // paint background using BackColor
      of_PaintBackColor(ll_MemDC)
   End If
End If

// trigger event in descendant
this.Event OnPaint(ll_MemDC)

// copy buffer to device context
BitBlt(ll_hDC, 0, 0, rc.Right, rc.Bottom, &
       ll_MemDC, 0, 0, SRCCOPY)
SelectObject(ll_MemDC, ll_OrigBitmap)

// cleanup memory objects
DeleteObject(ll_MemBitmap)
DeleteDC(ll_MemDC)

// mark painting as complete
EndPaint(il_hCanvas, ps)

Return 0

end event

event wm_erasebkgnd;// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.wm_erasebkgnd
//
// PURPOSE:    Prevent system from erasing the background
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

Return 1

end event

protected subroutine of_settransparent (boolean ab_set);// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.of_SetTransparent
//
// PURPOSE:    This function sets the Transparent background option.
//
// ARGUMENTS:  ab_set   - Option value
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

IsTransparent = ab_set

SetRedraw(True)

end subroutine

public function string pbvmname ();// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.PBVMName
//
// PURPOSE:    This function returns the name of the PowerBuilder VM.
//
// RETURN:     PowerBuilder VM name
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// 05/26/2015  RolandS     Updated for PB 12.6
// 02/10/2021  RolandS     Updated for PB 2019-R3
// -----------------------------------------------------------------------------

Environment le_env
String ls_vmname
Integer li_major, li_minor

GetEnvironment(le_env)

li_major = le_env.PBMajorRevision
li_minor = le_env.PBMinorRevision

choose case li_major
   case 10, 11, 12, 17
      choose case li_minor
         case 5
            ls_vmname = "pbvm" + String(li_major) + "5.dll"
         case 6
            ls_vmname = "pbvm" + String(li_major) + "6.dll"
         case else
            ls_vmname = "pbvm" + String(li_major) + "0.dll"
      end choose
   case 19
      If li_minor < 2 Then
         ls_vmname = "pbvm190.dll"
      Else
         ls_vmname = "pbvm.dll"
      End If
   case else
      ls_vmname = "pbvm.dll"
end choose

Return ls_vmname

end function

public function long getpbcolor (long al_color);// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.GetPBColor
//
// PURPOSE:    This function gets system colors from PowerBuilder colors.
//
// ARGUMENTS:  al_color - PowerBuilder Color Code
//
// RETURN:     The color value
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

Long ll_color, ll_SysColor

choose case al_color
   case 1073741824   // Window Background
      ll_color = GetSystemColor(5)     // COLOR_WINDOW
   case 33554432     // Window Text
      ll_color = GetSystemColor(8)     // COLOR_WINDOWTEXT
   case 268435456    // Application Workspace
      ll_color = GetSystemColor(12)    // COLOR_APPWORKSPACE
   case 67108864     // Button Face
      ll_color = GetSystemColor(15)    // COLOR_BTNFACE
   case 134217856    // Link
      ll_color = 16711680              // Blue
   case 134217857    // Link Hover
      ll_color = 255                   // Red
   case 134217858    // Link Active
      ll_color = 8388736               // Purple
   case 134217859    // Link Visited
      ll_color = 8388736               // Purple
   case else
      ll_SysColor = al_color - 16777216
      If ll_SysColor < 0 Then
         // Actual Color
         ll_color = al_color
      Else
         If al_color > 134217728 Then
            // System Color not listed above
            ll_SysColor = al_color - 134217728
            ll_color = GetSystemColor(ll_SysColor)
         Else
            // IDE Custom Color
            ll_color = ll_SysColor
         End If
      End If
end choose

Return ll_color

end function

public subroutine setpaintbackground (boolean ab_set);// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.SetPaintBackground
//
// PURPOSE:    This function sets the option to use parent to draw background.
//
// ARGUMENTS:  ab_set   - Option value
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

PaintBackground = ab_set

SetRedraw(True)

end subroutine

private subroutine of_paintbackground (longptr hdc, integer xpbu, integer ypbu, integer wpbu, integer hpbu);// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.of_PaintBackground
//
// PURPOSE:    This function paints the background of a child canvas.
//
// ARGUMENTS:  hdc   - Device context
//             xpbu  - X coordinate in PBUnits
//             ypbu  - Y coordinate in PBUnits
//             wpbu  - Width in PBUnits
//             hpbu  - Height in PBUnits
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

Constant Long SRCCOPY = 13369376
RECT rc
Longptr ll_MemDC, ll_MemBitmap, ll_OrigBitmap
Integer li_xpix, li_ypix, li_wpix, li_hpix

// convert location and size of child to pixels
li_xpix = UnitsToPixels(xpbu, XUnitsToPixels!)
li_ypix = UnitsToPixels(ypbu, YUnitsToPixels!)
li_wpix = UnitsToPixels(wpbu, XUnitsToPixels!)
li_hpix = UnitsToPixels(hpbu, YUnitsToPixels!)

// determine control size
GetClientRect(il_hCanvas, rc)

// set up bitmap buffer
ll_MemDC = CreateCompatibleDC(hdc)
ll_MemBitmap = CreateCompatibleBitmap(hdc, rc.Right, rc.Bottom)
ll_OrigBitmap = SelectObject(ll_MemDC, ll_MemBitmap)

// paint background using BackColor
If IsTransparent Then
   of_PaintBackColor(ll_MemDC)
End If

// trigger event in descendant
this.Event OnPaint(ll_MemDC)

// copy buffer to device context
BitBlt(hdc, 0, 0, li_wpix, li_hpix, &
       ll_MemDC, li_xpix, li_ypix, SRCCOPY)
SelectObject(ll_MemDC, ll_OrigBitmap)

// cleanup memory objects
DeleteObject(ll_MemBitmap)
DeleteDC(ll_MemDC)

end subroutine

protected subroutine of_paintbackcolor (longptr hdc);// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.of_PaintBackColor
//
// PURPOSE:    This function paints the background when Transparent is true.
//
// ARGUMENTS:  hdc - Device context
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// -----------------------------------------------------------------------------

RECT rc
Longptr ll_Brush

// determine control size
GetClientRect(il_hCanvas, rc)

// create a brush
ll_Brush = CreateSolidBrush(this.BackColor)

// fill the background
FillRect(hdc, rc, ll_Brush)

end subroutine

on u_canvas.create
end on

on u_canvas.destroy
end on

event constructor;// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.constructor
//
// PURPOSE:    Initialize the control
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// 10/27/2017  RolandS     Added code to handle 64bit
// -----------------------------------------------------------------------------

Environment le_env
PowerObject lpo_parent
UserObject luo_parent
Window lwn_parent
Tab ltb_parent
Longptr ll_Module, ll_Address

// determine if running 64bit mode
GetEnvironment(le_env)
ProcessBitness = le_env.ProcessBitness

// save the control handle
il_hCanvas = Handle(this)

// redirect the control WinProc
ll_Module = GetModuleHandle(PBVMName())
If ll_Module > 0 Then
   // ordinal value for FN_UserExternalWnd = 20
   ll_Address = GetProcAddress(ll_Module, 20)
   If ll_Address > 0 Then
      If ProcessBitness = 64 Then
         il_OriginalProc = SetWindowLong64(il_hCanvas, &
                                 GWL_WNDPROC, ll_Address)
      Else
         il_OriginalProc = SetWindowLong32(il_hCanvas, &
                                 GWL_WNDPROC, ll_Address)
      End If
   End If
End If

// set BackColor to parent BackColor
lpo_parent = this.GetParent()
choose case lpo_parent.TypeOf()
   case Tab!
      ltb_parent = lpo_parent
      this.BackColor = GetPBColor(ltb_parent.BackColor)
   case UserObject!
      luo_parent = lpo_parent
      this.BackColor = GetPBColor(luo_parent.BackColor)
   case Window!
      lwn_parent = lpo_parent
      this.BackColor = GetPBColor(lwn_parent.BackColor)
end choose

end event

event destructor;// -----------------------------------------------------------------------------
// SCRIPT:     u_canvas.destructor
//
// PURPOSE:    Perform cleanup tasks
//
// DATE        PROG/ID     DESCRIPTION OF CHANGE / REASON
// ----------  --------    -----------------------------------------------------
// 07/31/2013  RolandS     Initial coding
// 10/27/2017  RolandS     Added code to handle 64bit
// -----------------------------------------------------------------------------

// restore the control WinProc
If ProcessBitness = 64 Then
   SetWindowLong64(il_hCanvas, GWL_WNDPROC, il_OriginalProc)
Else
   SetWindowLong32(il_hCanvas, GWL_WNDPROC, il_OriginalProc)
End If

end event