Code:
'SED_PBWIN
#COMPILE EXE
#DIM ALL
#DEBUG ERROR ON
#INCLUDE "WIN32API.INC"
' *********************************************************************************************
' Get type of character set - ansi, symbol.. a must for some fonts.
' *********************************************************************************************
FUNCTION EnumCharSet (elf AS ENUMLOGFONT, ntm AS NEWTEXTMETRIC, BYVAL FontType AS LONG, CharSet AS LONG) AS LONG
CharSet = elf.elfLogFont.lfCharSet
END FUNCTION
' *********************************************************************************************
' *********************************************************************************************
' Create a desirable font and return its handle. Original code by Dave Navarro
' NOTE: enhanced with proper enumeration of character set via chmEnumFontDataProc
' *********************************************************************************************
FUNCTION MakeFontEx(BYVAL FontName AS STRING, BYVAL PointSize AS LONG, BYVAL fBold AS LONG, BYVAL fItalic AS LONG, _
BYVAL fUnderline AS LONG) AS DWORD
LOCAL hDC AS DWORD, CharSet AS LONG, CyPixels AS LONG
hDC = GetDC(%HWND_DESKTOP)
CyPixels = GetDeviceCaps(hDC, %LOGPIXELSY)
EnumFontFamilies hDC, BYVAL STRPTR(FontName), CODEPTR(EnumCharSet), BYVAL VARPTR(CharSet)
ReleaseDC %HWND_DESKTOP, hDC
PointSize = 0 - (PointSize * CyPixels) \ 72
FUNCTION = CreateFont(PointSize, 0, _ 'height, width(default=0)
0, 0, _ 'escapement(angle), orientation
fBold, _ 'weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700)
fItalic, _ 'Italic
fUnderline, _ 'Underline
%FALSE, _ 'StrikeThru
CharSet, %OUT_TT_PRECIS, _
%CLIP_DEFAULT_PRECIS, %DEFAULT_QUALITY, _
%FF_DONTCARE , BYCOPY FontName)
END FUNCTION
SUB DrawGradient (BYVAL hDC AS DWORD)
LOCAL rectFill AS RECT
LOCAL rectClient AS RECT
LOCAL fStep AS SINGLE
LOCAL hBrush AS DWORD
LOCAL lOnBand AS LONG
GetClientRect WindowFromDC(hDC), rectClient
fStep = rectClient.nbottom / 200
FOR lOnBand = 0 TO 199
SetRect rectFill, 0, lOnBand * fStep, rectClient.nright + 1, (lOnBand + 1) * fStep
hBrush = CreateSolidBrush(RGB((255 - lOnBand), (255 - lOnBand), (255 - lOnBand)))
Fillrect hDC, rectFill, hBrush
DeleteObject hBrush
NEXT
END SUB
' *********************************************************************************************
' Main
' *********************************************************************************************
FUNCTION WINMAIN (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS ASCIIZ PTR, BYVAL nCmdShow AS LONG) AS LONG
LOCAL hWndMain AS dword
LOCAL hCtl AS DWORD
LOCAL hFont AS DWORD
LOCAL wcex AS WndClassEx
LOCAL szClassName AS ASCIIZ * 80
LOCAL rc AS RECT
LOCAL szCaption AS asciiz * 255
LOCAL nLeft AS LONG
LOCAL nTop AS LONG
LOCAL nWidth AS LONG
LOCAL nHeight AS LONG
hFont = GetStockObject(%ANSI_VAR_FONT)
' Register the window class
szClassName = "MyClassName"
wcex.cbSize = SIZEOF(wcex)
wcex.style = %CS_HREDRAW OR %CS_VREDRAW
wcex.lpfnWndProc = CODEPTR(WndProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = hInstance
wcex.hCursor = LoadCursor (%NULL, BYVAL %IDC_ARROW)
wcex.hbrBackground = %COLOR_3DFACE + 1
wcex.lpszMenuName = %NULL
wcex.lpszClassName = VARPTR(szClassName)
wcex.hIcon = LoadIcon (%NULL, BYVAL %IDI_APPLICATION) ' Sample, if resource icon: LoadIcon(hInst, "APPICON")
wcex.hIconSm = LoadIcon (%NULL, BYVAL %IDI_APPLICATION) ' Remember to set small icon too..
RegisterClassEx wcex
' Window caption
szCaption = "SDK Main Window"
' Retrieve the size of the working area
SystemParametersInfo %SPI_GETWORKAREA, 0, BYVAL VARPTR(rc), 0
' Calculate the position and size of the window
nWidth = (((rc.nRight - rc.nLeft)) + 2) * 0.25 ' 75% of the client screen width
nHeight = (((rc.nBottom - rc.nTop)) + 2) * 0.20 ' 70% of the client screen height
nLeft = ((rc.nRight - rc.nLeft) \ 2) - nWidth \ 2
nTop = ((rc.nBottom - rc.nTop) \ 2) - (nHeight \ 2)
' Create a window using the registered class
hWndMain = CreateWindowEx(%WS_EX_CONTROLPARENT, _ ' extended style
szClassName, _ ' window class name
szCaption, _ ' window caption
%WS_OVERLAPPEDWINDOW OR _
%WS_CLIPCHILDREN, _ ' window style
nLeft, _ ' initial x position
nTop, _ ' initial y position
nWidth, _ ' initial x size
nHeight, _ ' initial y size
%NULL, _ ' parent window handle
0, _ ' window menu handle
hInstance, _ ' program instance handle
BYVAL %NULL) ' creation parameters
hCtl = CreateWindowEx(0, "BUTTON", "&Ok", %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP Or %BS_OWNERDRAW, _
0, 0, 0, 0, hWndMain, %IDOK, hInstance, BYVAL %NULL)
IF hFont THEN SendMessage hCtl, %WM_SETFONT, hFont, 0
' Show the window
ShowWindow hWndMain, nCmdShow
UpdateWindow hWndMain
' Message handler loop
LOCAL Msg AS tagMsg
WHILE GetMessage(Msg, %NULL, 0, 0)
IF ISFALSE IsDialogMessage(hWndMain, Msg) THEN
TranslateMessage Msg
DispatchMessage Msg
END IF
WEND
FUNCTION = msg.wParam
END FUNCTION
' *********************************************************************************************
' *********************************************************************************************
' Main Window procedure
' *********************************************************************************************
FUNCTION WndProc (BYVAL hWnd AS DWORD, BYVAL wMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
Local hOldFnt As Dword, szText As Asciiz * 128
Local dis As DRAWITEMSTRUCT Ptr, hPen As Dword, hBrush As Dword
LOCAL rc AS RECT
local hFont as LONG
static hIcon As long
SELECT CASE wMsg
case %WM_CREATE
hIcon = LoadIcon(ByVal 0, ByVal %IDI_ASTERISK)
Case %WM_DRAWITEM
dis = lParam
if @dis.CtlId = %IDOK then
rc = @dis.rcItem
If (@dis.itemState And %ODS_SELECTED) Then
DrawGradient(@dis.hDc)
DrawEdge @dis.hDc, rc, %EDGE_SUNKEN , %BF_RECT
rc.nRight = rc.nRight -4
rc.nbottom = rc.nBottom-4
rc.nLeft = rc.nLeft - 4
Else
DrawGradient(@dis.hDc)
DrawEdge @dis.hDc, rc, %EDGE_RAISED , %BF_RECT
End If
DrawIconEx @Dis.hDc, rc.nLeft+ 30 , rc.nTop + 14 , _ '
hIcon, 16, 16, 0, 0, %DI_NORMAL
SetBkMode @dis.hDc, %Transparent
SetTextColor @dis.hDc, rgb(200,255,0)
SendMessage @dis.hWndItem, %WM_GETTEXT, SizeOf(szText), VarPtr(szText)
hFont = MakeFontEx("Arial", 12, %FW_BOLD , 0, 0)
IF hFont THEN
hFont = SelectObject(@dis.hDC, hFont)
end if
DrawText @dis.hDc, szText, Len(szText), rc, %DT_CENTER Or %DT_VCENTER Or %DT_SINGLELINE
IF hFont THEN
DeleteObject SelectObject(@dis.hDC, hFont)
end if
Function = %True
end if
CASE %WM_SIZE
IF wParam <> %SIZE_MINIMIZED THEN
GetClientRect hWnd, rc
MoveWindow GetDlgItem(hWNd, %IDOK), 65, 35, 120, 43, %TRUE
END IF
CASE %WM_COMMAND
' -------------------------------------------------------
' Messages from controls and menu items are handled here.
' -------------------------------------------------------
SELECT CASE LOWRD(wParam)
CASE %IDOK
IF HIWRD(wParam) = %BN_CLICKED THEN
' SendMessage hWnd, %WM_DESTROY, wParam, lParam
' FUNCTION = 0
END IF
END SELECT
CASE %WM_SYSCOMMAND
' Capture this message and send a WM_CLOSE message
IF (wParam AND &HFFF0) = %SC_CLOSE THEN
SendMessage hWnd, %WM_CLOSE, wParam, lParam
EXIT FUNCTION
END IF
CASE %WM_DESTROY
' ---------------------------------------------------------------------------
' Is sent when program ends - a good place to delete any created objects and
' store settings in file for next run, etc. Must send PostQuitMessage to end
' properly in SDK-style dialogs. The PostQuitMessage function sends a WM_QUIT
' message to the program's (thread's) message queue, and then WM_QUIT causes
' the GetMessage function to return zero in WINMAIN's message loop.
' ---------------------------------------------------------------------------
PostQuitMessage 0 ' This function closes the main window
FUNCTION = 0 ' by sending zero to the main message loop
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
END FUNCTION
' *********************