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 ( unsignedlong hdc )
end type
global u_canvas u_canvas

type prototypes
Protected:

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

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

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

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

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

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

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

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

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

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

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

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

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

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

Function Integer FillRect( &
   Long hDC, &
   RECT lpRect, &
   Long 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
Long il_hCanvas
Long il_OriginalProc

end variables

forward prototypes
protected subroutine of_settransparent (boolean ab_set)
public function string pbvmname ()
public function long getpbcolor (long al_color)
private subroutine of_paintbackground (long hdc, integer xpbu, integer ypbu, integer wpbu, integer hpbu)
public subroutine setpaintbackground (boolean ab_set)
protected subroutine of_paintbackcolor (long 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
Long 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

private subroutine of_paintbackground (long 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
Long 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

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

protected subroutine of_paintbackcolor (long 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
Long 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
// -----------------------------------------------------------------------------

PowerObject lpo_parent
UserObject luo_parent
Window lwn_parent
Tab ltb_parent
Long ll_Module, ll_Address

// 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
      il_OriginalProc = SetWindowLong(il_hCanvas, GWL_WNDPROC, ll_Address)
   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
// -----------------------------------------------------------------------------

// restore the control WinProc
SetWindowLong(il_hCanvas, GWL_WNDPROC, il_OriginalProc)

end event