Hello All
this is a Date Picker program which i had modified from Roland's program located at
https://www.oxygenbasic.org/forum/index.php?topic=1754.msg19508;topicseen#msg19508 (https://www.oxygenbasic.org/forum/index.php?topic=1754.msg19508;topicseen#msg19508)
i have also modified the include file for this WinutilMod.inc so that users can change the Main window title
and its background color using variables MainWindTitle and MainWindBGColor
Thanxx to Charles and Roland
the DatePicker.o2bas
' DatePick and MonthCalendar in TabPages
' DatePicker.o2bas
' https://www.oxygenbasic.org/forum/index.php?topic=1754.msg19508;topicseen#msg19508
$ filename = "DatePicker.exe"
uses rtl64
' Use a modified version of WinUtil.inc
uses winutilMod
' additional items
% COLOR_MENU=4
% DTN_DATETIMECHANGE= -759
% DTS_SHOWNONE=2
% DTS_LONGDATEFORMAT=4
% MCN_SELECT= -746
% MCN_SELCHANGE= -749
% TCIF_TEXT=1
% TCM_INSERTITEM=4871
% TCM_GETCURSEL=4875
% TCN_SELCHANGE= dword -551 'Win64
% TCN_SELCHANGING= dword -552 'Win64
% TCN_FIRST= dword -550 'Win64
% TCN_LAST= dword -580 'Win64
% TCS_TABS=0
% TCS_SINGLELINE=0
% TCS_FOCUSONBUTTONDOWN=4096
type TCITEM
int mask,dwState,dwStateMask
char* pszText
int cchTextMax,iImage
sys lParam
end type
typedef TCITEM TC_ITEM
def varptr @ %1
def codeptr @ %1
' Identifiers
%IDTAB_MAIN = 100
%IDTAB_PAGE_1 = 101
%IDTAB_PAGE_2 = 102
%ID_Exit = 103
%ID_Datetime = 1000
%ID_Monthcalendar = 1001
DECLARE FUNCTION CreateMainTabControl(BYVAL hWnd AS LONG) AS LONG
DECLARE SUB CreateTabPage1(BYVAL hTab AS LONG)
DECLARE SUB CreateTabPage2(BYVAL hTab AS LONG)
DECLARE FUNCTION OnEventTabPage1(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG,BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG
DECLARE FUNCTION OnEventTabPage2(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG,BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG
INITCOMMONCONTROLSEXt icce
'Load the common controls library...
icce.dwSize = sizeof(INITCOMMONCONTROLSEXt)
icce.dwICC = 0xffff
InitCommonControlsEx(&icce)
char* cmdline
@cmdline=GetCommandLine()
sys hInstance = GetModuleHandle(null)
indexbase 0
sys g_hTab[1] '2 TabPages
' Display the main window to cover the 2 tabs
' Note that MainWindow function is located in the WinUtilMod.inc
MainWindTitle = "Date Picker"
' for Green background for main window
MainWindBGColor = 3
MainWindow 395,320, WS_OVERLAPPEDWINDOW
'-------------------------------------------------
FUNCTION WndProc(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG,BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG callback
LOCAL PageNo AS LONG, hButton AS LONG
NMHDR *ptnmhdr
WNDCLASSEX wcx
sys hDC
SELECT CASE (wMsg)
CASE %WM_CREATE
'Register the Tab page holder windows...
string szClassName = "TabPageChild"
wcx.cbSize = sizeof(WNDCLASSEX)
wcx.lpfnWndProc = @TabPageProc
wcx.hInstance = hInstance
wcx.hbrBackground = COLOR_MENU +1
wcx.lpszClassName = strptr szClassName
if RegisterClassEx(&wcx) = 0 then mbox "Cannot register TabPage Window"
hButton = CreateWindowEx(0, "BUTTON", "Exit",%WS_CHILD OR %WS_CLIPSIBLINGS OR %WS_TABSTOP OR
%WS_VISIBLE OR %BS_PUSHBUTTON,
111,240,80,30,
hWnd, %ID_Exit, hInst, BYVAL %NULL)
CALL CreateMainTabControl(hWnd)
CALL SetFocus(GetDlgItem(hWnd,%ID_Exit))
CASE %WM_COMMAND
SELECT CASE LOWORD(wParam)
CASE %ID_Exit
IF HIWORD(wParam) = %BN_CLICKED THEN
CALL SendMessage(hWnd,%WM_CLOSE,0,0)
END IF
END SELECT
CASE %WM_NOTIFY
@ptnmhdr = lParam
'This does work
if ptnmhdr.code >= %TCN_LAST and ptnmhdr.code <= %TCN_FIRST then
SELECT CASE ptnmhdr.idFrom
CASE %IDTAB_MAIN
if ptnmhdr.code = TCN_SELCHANGING then
PageNo =SendMessage(GetDlgItem(hWnd,%IDTAB_MAIN),%TCM_GETCURSEL,0,0)
CALL ShowWindow(g_hTab(PageNo),%SW_HIDE)
elseif ptnmhdr.code = TCN_SELCHANGE then
PageNo = SendMessage(GetDlgItem(hWnd,%IDTAB_MAIN),%TCM_GETCURSEL,0,0)
CALL ShowWindow(g_hTab(PageNo),%SW_SHOW)
end if
END SELECT
end if
' added to display background color for the main window
CASE %WM_ERASEBKGND
hDC = wParam
' Pass the DC of the region to repaint
DrawGradient hDC
FUNCTION = 1
EXIT FUNCTION
CASE %WM_CLOSE
CALL SendMessage(hWnd,%WM_DESTROY,0,0)
CASE %WM_DESTROY
CALL PostQuitMessage(0)
END SELECT
FUNCTION = DefWindowProc(hWnd,wMsg,wParam,lParam)
END FUNCTION
'------------------------------------------------------------------------------
FUNCTION CreateMainTabControl(BYVAL hWnd AS LONG) AS LONG
LOCAL hMainTab AS LONG,i AS LONG
LOCAL Style AS DWORD,StyleEx AS DWORD,ttc_item AS TC_ITEM
LOCAL szItem AS ASCIIZ*255
Style = %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR _
%TCS_TABS OR %TCS_SINGLELINE OR %TCS_FOCUSONBUTTONDOWN
StyleEx = 0
'Create tab control
hMainTab = CreateWindowEx(StyleEx,"SysTabControl32","",Style, _
6,6,368,235,
hWnd,%IDTAB_MAIN,hInst,BYVAL %NULL)
if hMainTab=0 then mbox "Cannot CreateWindowEx hMainTab"
'Insert tabs
DIM sText(1) AS STRING
sText(0) = "Date1"
sText(1) = "Date2"
FOR i = 0 TO 1
szItem = sText(i)
ttc_item.mask = %TCIF_TEXT
ttc_item.pszText = VARPTR(szItem)
ttc_item.cchTextMax = LEN(szItem)
ttc_item.iImage = -1
ttc_item.lParam = 0
SendMessage hMainTab,%TCM_INSERTITEM,i,VARPTR(ttc_item)
NEXT
'Create the individual Tab Pages
Style = %WS_CHILD
StyleEx = %WS_EX_CONTROLPARENT
FOR i = 0 TO 1
g_hTab(i) = CreateWindowEx(StyleEx,"TabPageChild","",Style, _
20,44,348,192,
hWnd,%IDTAB_PAGE_1+i,hInst,BYVAL %NULL)
NEXT
'Show Tab 1 as the default page
ShowWindow g_hTab(0), %SW_SHOW
FUNCTION = hMainTab
END FUNCTION
'------------------------------------------------------------------------------
FUNCTION TabPageProc(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG,BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG callback
LOCAL TabPageID AS INTEGER
TabPageID = GetDlgCtrlID(hWnd)
SELECT CASE (wMsg)
CASE %WM_CREATE
SELECT CASE (TabPageID)
CASE %IDTAB_PAGE_1 : CALL CreateTabPage1(hWnd)
CASE %IDTAB_PAGE_2 : CALL CreateTabPage2(hWnd)
END SELECT
CASE %WM_COMMAND, %WM_NOTIFY, %WM_HSCROLL, %WM_VSCROLL
SELECT CASE (TabPageID)
CASE %IDTAB_PAGE_1 : CALL OnEventTabPage1(hWnd,wMsg,wParam,lParam)
CASE %IDTAB_PAGE_2 : CALL OnEventTabPage2(hWnd,wMsg,wParam,lParam)
END SELECT
END SELECT
FUNCTION = DefWindowProc(hWnd,wMsg,wParam,lParam)
END FUNCTION
'------------------------------------------------------------------------------
FUNCTION OnEventTabPage1(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG,BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG
NMHDR ptnmhdr at lParam
SELECT CASE (wMsg)
CASE %WM_NOTIFY
SELECT CASE ptnmhdr.idFrom
CASE %ID_Datetime
SELECT CASE ptnmhdr.code
CASE %DTN_DATETIMECHANGE
END SELECT
END SELECT
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
FUNCTION OnEventTabPage2(BYVAL hWnd AS LONG,BYVAL wMsg AS LONG,BYVAL wParam AS LONG,BYVAL lParam AS LONG) AS LONG
NMHDR ptnmhdr at lParam
SELECT CASE (wMsg)
CASE %WM_NOTIFY
SELECT CASE ptnmhdr.idFrom
CASE %ID_Monthcalendar
'Month/Calendar
SELECT CASE ptnmhdr.code
CASE %MCN_SELECT
CASE %MCN_SELCHANGE
END SELECT
END SELECT
END SELECT
END FUNCTION
'------------------------------------------------------------------------------
' Create the Tab page 1
SUB CreateTabPage1(BYVAL hTab AS LONG)
LOCAL hCtl AS LONG
LOCAL Style AS DWORD,StyleEx AS DWORD,lflags AS DWORD
LOCAL sText AS STRING
'---
Style = %WS_CHILD OR %WS_CLIPSIBLINGS OR %WS_TABSTOP OR _
%WS_VISIBLE OR %DTS_LONGDATEFORMAT OR %DTS_SHOWNONE
StyleEx = %WS_EX_LEFT OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
hCtl = CreateWindowEx(StyleEx, "SysDateTimePick32", "DateTime",Style, _
40,48,200,26, _
hTab, %ID_Datetime, hInst, BYVAL %NULL)
END SUB
'------------------------------------------------------------------------------
' Create the Tab page 2
SUB CreateTabPage2(BYVAL hTab AS LONG)
LOCAL hCtl AS LONG
LOCAL Style AS DWORD,StyleEx AS DWORD,lflags AS DWORD
LOCAL sText AS STRING
Style = %WS_CHILD OR %WS_CLIPSIBLINGS OR %WS_TABSTOP OR %WS_VISIBLE
StyleEx = %WS_EX_LEFT OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
hCtl = CreateWindowEx(StyleEx, "SysMonthCal32", "MonthCalender",Style, _
48,8,232,184, _
hTab, %ID_Monthcalendar, hInst, BYVAL %NULL)
END SUB
the WinUtilMod.inc file
'14:53 23/09/2017
'22:50 10/03/2018
' Modified to display the main window Title MainWindTitle
' with a color background
uses corewin
'
#ifdef FileDialogs
uses FileDialog
#endif
'
/*
https://msdn.microsoft.com/en-us/library/windows/desktop/ms724947(v=vs.85).aspx
BOOL WINAPI SystemParametersInfo(
_In_ UINT uiAction,
_In_ UINT uiParam,
_Inout_ PVOID pvParam,
_In_ UINT fWinIni
);
'uiAction
% SPI_GETWORKAREA 0x0030
'fWinIni
% SPIF_UPDATEINIFILE 0x01
% SPIF_SENDCHANGE 0x02
*/
int hpos,vpos,WaWidth,WaHeight
int spinfo[4]
scope
SystemParametersInfo 0x0030,0,@spinfo,0
indexbase 1
WaWidth=spinfo[3]
WaHeight=spinfo[4]
end scope
'not used
'hpos=CW_USEDEFAULT
'vpos=CW_USEDEFAULT
'
'SHARED STATE SERVER SIDE
'------------------------
'
sys bu[0x400] 'STATIC BUFFER TO HOLD STATE VARIABLES
'function guistate() as sys export = @bu
sys guistate() export {#noinit : return @bu}
'
'--------------------------------------
'INCLUDE ON BOTH SERVER AND CLIENT SIDE
'--------------------------------------
sys b
b = guistate()
bind b {
sys hWndMain,hInst,hDC,hRC,inst
int pixelform
int mposx,mposy,sposx,sposy,eposx,eposy,iposx,iposy
int mmove,bleft,bmid,bright,bwheel
int pause
int bkey,keyd,lastkey,lastchar
int running
int key[256]
}
'--------------------------------------
#undef b 'MAKE INVISIBLE
#undef bu 'MAKE INVISIBLE
int isRegistered
int running=1
int minCreate, RebuildWindow
RECT crect
string cr=chr(13)+chr(10), tab=chr(9), qu=chr(34)
#ifndef width
int width=640
int height=480
#endif
' Added Oct 30 2018
' Title for the main window
string MainWindTitle
' Background color for main window
int MainWindBGColor
'=============================== Added Oct 30 2018
' for displaying the RGB colors
Function RGB(sys red,green,blue) as sys
sys color
color = red
color = color + green*256
color = color + blue*65536
Return color
End Function
'======================================== Added Oct 30 2018
' draws with color gradient
SUB DrawGradient (BYVAL hDC AS DWORD)
LOCAL rectFill AS RECT, rectClient AS RECT, fStep AS SINGLE
local hBrush AS DWORD, lOnBand AS LONG
GetClientRect WindowFromDC(hDC), rectClient
fStep = rectClient.bottom / 75
FOR lOnBand = 0 TO 50 ' 199
SetRect rectFill, 0, lOnBand * fStep, rectClient.right + 1, (lOnBand + 1) * fStep
' paint the background -- change the first 2 colors R and G
' to vary the color gradient
Select case MainWindBGColor
Case 1
' this gives a light yellow background
hBrush = CreateSolidBrush(rgb(255, 255, 205 - lOnBand))
Case 2
' this gives a cyan background
hBrush = CreateSolidBrush(rgb(0, 248, 255 - lOnBand))
Case 3
' this gives a light green background
hBrush = CreateSolidBrush(rgb(155, 250, 147 - lOnBand))
End Select
Fillrect hDC, rectFill, hBrush
DeleteObject hBrush
NEXT
END SUB
macro CreateMainWindow
======================
hwnd = CreateWindowEx(
0, 'extended styles
"wins", 'class name
MainWindTitle, 'window name
style, '
hpos, 'horizontal position
vpos, 'vertical position
width, 'width
height, 'height
null, 'no parent or owner window
null, 'class menu used
hInst, 'instance handle
null); 'no window creation data
if not hWnd then
MessageBox 0,"Unable to create window","problem",MB_ICONERROR
exit function
end if
end macro
'
#ifdef OpenGL
uses glWinUtil
#endif 'Opengl
'
'
macro LogMousePos
=================
mposx=LoWord[lparam]
mposy=HiWord[lparam]
sPosX=mPosX : sPosY=mPosy
iPosX=mPosX : iPosY=mPosy
'GetCursorPos @mp
'sp=mp
act=1
end macro
macro MouseMessages
===================
case WM_MOUSEMOVE
mposx=LoWord(lparam)
mposy=HiWord(lparam)
mmove=1
if act=0 then act=1
static POINT sp,mp
'if bleft
' 'adjust window position
' scope
' POINT q 'MOUSE POSITION ON SCREEN
' RECT r 'WINDOW RECT ON SCREEN
' int w,h
' GetWindowRect hwnd,@r
' GetCursorPos @mp
' w=r.right-r.left
' h=r.bottom-r.top
' if mposy<32 'MOUSE POSITION IN CLIENT AREA
' if mposx>w*.75 'stretch right
' w=w+mp.x-sp.x
' h=h-mp.y+sp.y
' q.y=q.y+mp.y-sp.y
' elseif mposx<32 'menu?
' else 'move
' q.x=mp.x-sp.x
' q.y=mp.y-sp.y
' end if
' moveWindow hwnd,r.left+q.x,r.top+q.y,w,h,1
' sp=mp
' end if
' end scope
'end if
case WM_LBUTTONDOWN : bleft=1 : LogMousePos
case WM_LBUTTONUP : bleft=0 : eposx=mposx
case WM_RBUTTONDOWN : bright=1 : LogMousePos
case WM_RBUTTONUP : bright=0 : eposx=mposx
case WM_MBUTTONDOWN : bMid=1 : LogMousePos
case WM_MBUTTONUP : bMid=0 : eposx=mposx
case WM_MOUSEWHEEL : bWheel=wParam : sar bWheel,16
end macro
macro KeyboardMessages
======================
case WM_CHAR : lastchar=wparam
case WM_KEYUP : key[wparam]=0 : keyd=0 : if wparam>30 then bkey=0
case WM_KEYDOWN
wparam and= 255
select case wparam
keydown 'macro intercept
'DEFAULT CASES
case 27 : SendMessage hwnd, WM_CLOSE, 0, 0
case 32 : if key[32]=0 then pause=1-pause 'toggle
end select
key[wparam]=1
lastkey=wparam
bkey=lastkey
keyd=lastkey
#ifdef opengl
act=1
#endif
end macro
'MICROSECOND TIMER
==================
'
macro TimeMark(c)
=================
QueryPerformanceCounter @c
end macro
'
function TimeDiff(quad *te,*ts) as double
=========================================
static quad freq
QueryPerformanceFrequency @freq
return (te-ts)/freq 'SECONDS
end function
'
function AppExePath(optional sys n) as char*
==============================
static byte b[512]
sys i=GetModuleFileName(GetModuleHandle(0), @b, 512)
while b[i] != 0x5c '92 '\'
i--
wend
if not n then i++ 'include the '\' by default
b[i]=0
= @b 'low level
return
end function
function GetClientWHXY(sys hWnd, *w,*h,*x,*y)
=============================================
RECT rc
POINT pt
GetClientRect(hwnd, @rc)
GetCursorPos @pt
w=rc.right*.25
h=rc.bottom
ScreenToClient hWnd,@pt
x=pt.x
y=pt.y
end function
function GetDropFiles(sys hDropParam) As string
===============================================
string sDropFiles, sFile
sys i,e,le
e=DragQueryFile(hDropParam, -1, null, 0)-1
'
for i = 0 To e
le=DragQueryFile(hDropParam, i, null, 1)
sfile=space le
DragQueryFile(hDropParam, i, StrPtr sFile, le+1)
If Ucase(mid(sFile, -4)) = ".LNK"
else
sDropFiles+= sFile + chr(13,10)
end if
next i
return sDropFiles
end function
/*
=====
NOTES
=====
STANDARD CHILD WINDOWS STYLES
'
Button The class for a button.
ComboBox The class for a combo box.
Edit The class for an edit control.
ListBox The class for a list box.
MDIClient The class for an MDI client window.
ScrollBar The class for a scroll bar.
Static The class for a static control.
BOOL WINAPI CreateProcess(
1 __in_opt LPCTSTR lpApplicationName,
2 __inout_opt LPTSTR lpCommandLine,
3 __in_opt LPSECURITY_ATTRIBUTES lpProcessAttributes,
4 __in_opt LPSECURITY_ATTRIBUTES lpThreadAttributes,
5 __in BOOL bInheritHandles,
6 __in DWORD dwCreationFlags,
7 __in_opt LPVOID lpEnvironment,
8 __in_opt LPCTSTR lpCurrentDirectory,
9 __in LPSTARTUPINFO lpStartupInfo,
10 __out LPPROCESS_INFORMATION lpProcessInformation
);
*/
'
'
Function MainWindow
===================
(
int widthp=640,
heightp=480,
style=WS_OVERLAPPEDWINDOW,
place=2
)
width=widthp
height=heightp
select place 'default, left, centre, right
case 0 : hpos=32 : vpos=32
case 1 : hpos=0: vpos=0
case 2 : hpos=(wawidth-width)\2 : vpos=(WaHeight-height-32)\2
if vpos<0 then vpos=0
case 3 : hpos=wawidth-width-6 : vpos=0
end select
'
indexbase 0
sys a,b,c,hWnd
WNDCLASSEX wc
MSG wm
'globals hDC, hRC, hInst, minCreate
'
hInst=GetModuleHandle 0
inst=hinst
'cname="wins"
'
if isRegistered then goto nregister
'
with wc
.cbSize = sizeof WNDCLASSEX '
.style=CS_HREDRAW or CS_VREDRAW
.lpfnWndProc = @wndproc
.cbClsExtra = 0
.cbWndExtra = 0
.hInstance = hInst
.hIcon = LoadIcon 0, IDI_APPLICATION
.hCursor = LoadCursor 0,IDC_ARROW
.hbrBackground = GetStockObject WHITE_BRUSH
.lpszMenuName = 0
.lpszClassName = strptr "wins"
.hIconSm = null
end with
if not RegisterClassEx @wc
MessageBox 0,"Registration failed","Problem",MB_ICONERROR
exit function
end if
isRegistered=1
'
nregister:
==========
'
CreateMainWindow 'MACRO WITH OPENGL OVERRIDE
DragAcceptFiles(hwnd, true)
'
#ifdef WindowOpacity
'Set WS_EX_LAYERED on this window
SetWindowLong(hwnd, GWL_EXSTYLE,
GetWindowLong(hwnd, GWL_EXSTYLE) | WS_EX_LAYERED)
SetLayeredWindowAttributes(hwnd, 0, WindowOpacity, LWA_ALPHA);
#endif
'
ShowWindow hWnd,SW_NORMAL
UpdateWindow hWnd
hWndMain=hwnd
'
'MESSAGE LOOP
'============
'
sys bRet
'
#ifdef opengl
while running 'frame processing loop
while PeekMessage @wm, 0, 0, 0, PM_REMOVE
#else
while bRet := GetMessage @wm, 0, 0, 0
#endif
'
'if bRet == -1 then
' 'show an error message?
'else
#ifdef EscapeKeyEnd
if wm.message=WM_KEYDOWN
if wm.wparam=27
SendMessage hwnd,WM_CLOSE,0,0
end if
end if
#endif
'
#ifdef InMessageLoop
InMessageLoop ''CUMSTOMISED MESSAGE PROCESSING
#else
#ifdef MessageLoopProcesses
MessageLoopProcesses
#endif
TranslateMessage @wm
DispatchMessage @wm
#endif
wend 'GetMessage / PeekMessage
'
#ifdef Opengl
#ifdef ActOpengl
if not closing then
ActOpengl 'frame processing
end if
#endif
wend 'running
running=1 'READY FOR ANOTHER WINDOW
#endif
return 0
end function ' end MainWindow
sub UnregisterMain()
====================
UnregisterClass "wins",hInst
isRegistered=0
end sub
here's the display for the program
please improve on it and let me know how best to improve on this program
Here's the zip file for the program
hope that more programmers can join Oxygenbasic and contribute towards a better
64bit programming language. O2 is so flexible and capable