! BtnClrA.f90
! BtnClrA uses an XFlogm callback to colour a pushbutton. 
!
module BtnClr
use dfwin
use XFlogm
implicit none
include "BtnClrA.fd"
integer*4     :: hDlg
integer*4     :: hDlgProc
logical*4     :: lRet
integer*4, parameter :: BLUE                 = #FF0000
integer*4, parameter :: LIGHTGREEN           = #90EE90
integer*4, parameter :: RED                  = #0000FF
type (DIALOG) :: XDlg
contains
!
!-------------------------------------------------------------------------------
subroutine ShowDlg
! 
lRet=DlgInit(IDD_BTNCLR_DLG, XDlg)
!
! Register DLG_DRAWITEM "callback" for owner-drawn control.
! Requires XFlogm not DFlogm or IFlogm.
lRet = DlgSetSub(XDlg, IDCANCEL, PushbuttonCB, DLG_DRAWITEM)
lRet = DlgSetSub(XDlg, IDCANCEL, BCSub)
!lRet = DlgSet   (XDlg, IDCANCEL, 'Cancel'C)
!
lRet = DlgModal(XDlg)
call DlgUninit(XDlg)
end subroutine ShowDlg
!
!-------------------------------------------------------------------------------
subroutine BCSub(Dlg, ID, CallbackType )
! Main callback for IDD_BACKCOLOR_DIALOG
implicit none
type (DIALOG) :: Dlg
integer*4     :: ID, CallbackType
select case (ID)
  case (IDCANCEL)
    call DlgExit(Dlg)
end select
return
end subroutine BCSub
!
!-------------------------------------------------------------------------------
subroutine PushbuttonCB(Dlg, ID, hDC)
! PushbuttonCB is not a "classic" callback function -- the event to which it
! responds is WM_DRAWITEM message. WM_DRAWITEM is generated whenever
! (a portion of) owner-drawn static control is revealed.  Requires XFlogm.
! This routine sets the individual colours of the button(s).
!
implicit none
type (DIALOG) :: Dlg   ! Dialog.
integer*4     :: ID    ! Control ID.
integer*4     :: hDC   ! Handle of control's device context.
!
select case (ID)
  case (IDCANCEL)
    call ButtonColour(Dlg, ID, hDC, RED, LIGHTGREEN, BLUE)
end select
return
end subroutine PushbuttonCB
!
!-------------------------------------------------------------------------------
subroutine ButtonColour(Dlg, ID, hDC, BackBrushColour, TextBackColour, TextColour)
! Draws ownerdraw push button in colour.
type (DIALOG) :: Dlg        ! Dialogue containing pushbutton.
integer*4  :: ID            ! Button ID.           
integer*4  :: hDC           ! Handle of button's device context.
integer*4, optional :: BackBrushColour ! Button background colour.
integer*4, optional :: TextBackColour  ! Text background colour.
integer*4, optional :: TextColour      ! Text colour.
integer*4  :: hButton,    & ! Button handle.
              hOldBrush,  & ! Default DC brush (should be restored after drawing)
              hOldPen,    & ! Default DC pen (should be restored after drawing)
              hBrush,     & ! DC brush (must be destroyed after drawing)
              hPen,       & ! Empty pen handle.
              hTextColor, & ! Text colour handle.
              hTxBkColor, & ! Text background colour handle.
              iRet,       & ! Return value.
              lBtnStr       ! Trimmed length of button string
                  
logical*4     :: bRet       ! Return value.
character*20  :: ButtonStr  ! Button text.
type(T_RECT)  :: Rect       ! Button Rectangle.
hButton = GetDlgItem(Dlg.hWnd, ID)
iRet    = GetClientRect(hButton, Rect)          ! Get Client rectangle of the button & text.
lBtnStr = GetWindowText(hButton, ButtonStr, 20) ! Get Button text.
!
! Draw Button edge, adjusting size of coloured centre..
lRet = DrawFrameControl(hDC, Rect, DFC_BUTTON, IOR(DFCS_BUTTONPUSH, IOR(DFCS_PUSHED, DFCS_ADJUSTRECT)))
!
hBrush = CreateSolidBrush(BackBrushColour)   ! Button background brush.
hPen   = GetStockObject(NULL_PEN)            ! Standard pen
!
hOldBrush = SelectObject(hDC,hBrush)         ! Similar to QW SetColor
hOldPen   = SelectObject(hDC,hPen)

! This is Win32 API Rectangle, not MSFLIB Rectangle.
iRet = MSFWIN$Rectangle(hDC,0,0,Rect.Right,Rect.Bottom) ! Colours centre of Button.
hTextColor = MSFWIN$SetTextColor(hDC, TextColour)       ! Colours text.
hTxBkColor = MSFWIN$SetBKColor(hDC, TextBackColour)     ! Colours text background.
!
iRet = DrawText(hDC, ButtonStr, lBtnStr, Rect,                         & 
      IOR(DT_CENTER, IOR(DT_VCENTER, DT_SINGLELINE)))   ! Write Text.
!
! Delete brush & restore the default DC's brush
iRet = DeleteObject(SelectObject(hDC, hOldBrush))
! Delete pen & release Button DC.
iRet = SelectObject(hDC, hOldPen)
iRet = ReleaseDC(hButton, hDC)
!
end subroutine ButtonColour
!
end module BtnClr
!
!-------------------------------------------------------------------------------
integer function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow ) 
!MS$ ATTRIBUTES STDCALL, ALIAS : '_WinMain@16' :: WinMain 
!
use BtnClr
!
!Function parameters 
integer(4), intent(in) :: hInstance,hPrevInstance,nCmdShow,lpszCmdLine 
!
! call working program.
call ShowDlg
!
! Exit program 
WinMain = 0 
!
end 
