$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 long onpaint ( long hdc ) end type global u_canvas u_canvas type prototypes Protected: Function Long GetModuleHandle( & String lpModuleName & ) Library "kernel32.dll" Alias For "GetModuleHandleA" Function Long GetProcAddress( & Long hModule, & Long lpProcName & ) Library "kernel32.dll" Function Long SetWindowLong( & Long hWnd, & Integer nIndex, & Long dwNewLong & ) Library "user32.dll" Alias For "SetWindowLongA" 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" Function Boolean EndPaint( & Long hwnd, & PAINTSTRUCT lpPaint & ) Library "user32.dll" Alias For "EndPaint" 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 Long GetSystemColor( & Integer 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 // ----------------------------------------------------------------------------- Environment le_env String ls_vmname Integer li_major GetEnvironment(le_env) li_major = le_env.PBMajorRevision If li_major = 6 Then ls_vmname = "pbvm" + String(li_major) + "0.dll" Else choose case le_env.PBMinorRevision 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 End If 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
File: u_canvas.sru
Size: 13648
Date: Mon, 31 Dec 2018 21:14:38 +0100
Size: 13648
Date: Mon, 31 Dec 2018 21:14:38 +0100