I'm writing libraries of functions as a way to extend the PB language. Tonight I have written this function to complement the InStr function.
#COMPILE EXE
#DIM ALL
#INCLUDE "windows.inc"
#INCLUDE "RegExp.inc"
' ========================================================================================
' Global, multiline in string function with VBScript regular expressions search patterns.
' Parameters:
' - bstrText = The text.
' - bstrPattern = The pattern to match.
' - bIgnoreCase = Ignore case.
' Return Value:
' - Returns a list of comma separated "index, length" value pairs. The pairs are separated
' by a semicolon.
' ========================================================================================
FUNCTION AfxRegExpInStr (BYVAL bstrText AS WSTRING, BYVAL bstrPattern AS WSTRING, OPTIONAL BYVAL bIgnoreCase AS LONG) AS WSTRING
LOCAL i AS LONG
LOCAL nCount AS LONG
LOCAL idx AS LONG
LOCAL nLen AS LONG
LOCAL pRegExp AS IRegExp2
LOCAL pMatch AS IMatch
LOCAL pMatches AS IMatchCollection
LOCAL pDisp AS IDispatch
LOCAL bstrValue AS WSTRING
LOCAL bstrOut AS WSTRING
pRegExp = NEWCOM "VBScript.RegExp"
IF ISNOTHING(pRegExp) THEN EXIT FUNCTION
pRegExp.Pattern = bstrPattern
pRegExp.Global = -1
pRegExp.IgnoreCase = (bIgnoreCase <> 0)
pRegExp.Multiline = -1
pMatches = pRegExp.Execute(bstrText)
nCount = pMatches.Count
FOR i = 0 TO nCount - 1
pDisp = pMatches.Item(i)
pMatch = pDisp
bstrValue = pMatch.Value
idx = pMatch.FirstIndex
nLen = pMatch.Length
bstrOut += FORMAT$(idx + 1) & "," & FORMAT$(nLen) & ";"
NEXT
FUNCTION = LEFT$(bstrOut, LEN(bstrOut) - 1)
END FUNCTION
' ========================================================================================
FUNCTION PBMAIN
LOCAL bstrText AS WSTRING
LOCAL bstrPattern AS WSTRING
LOCAL bstrOut AS WSTRING
bstrText = "blah blah a234 blah blah x345 blah blah"
bstrPattern = "[A-Z][0-9][0-9][0-9]"
bstrOut = AfxRegExpInstr(bstrText, bstrPattern, %TRUE)
? bstrOut
END FUNCTION
http://www.planetsquires.com/protect/forum/index.php?topic=2823.msg21134#msg21134 (http://www.planetsquires.com/protect/forum/index.php?topic=2823.msg21134#msg21134)
QuoteNow, nothing can stop me to extend the language.
I guess you have started already!
Thanks for all your efforts and these great extensions, Jose. The PB future looks bright.
Just writing a couple of functions every day, you end with more than 700 in a year! They don't need to be complex, just useful.
Very often, people asks "How can I disable the X button"? So I have written this little function, ready to be used when you need it.
' ========================================================================================
' Removes the system menu close option and disables the X button.
' ========================================================================================
SUB AfxRemoveCloseMenu (BYVAL hwnd AS DWORD) COMMON
DIM hMenu AS DWORD
DIM cbItems AS LONG
' // Get the system menu handle
hMenu = GetSystemMenu(hwnd, 0)
IF hMenu = 0 THEN EXIT SUB
' // Get the number of menu items
cbItems = GetMenuItemCount(hMenu)
' // Remove the close menu item
RemoveMenu(hMenu, cbItems - 1, %MF_REMOVE OR %MF_BYPOSITION)
' // Remove the separator line
RemoveMenu(hMenu, cbItems - 2, %MF_REMOVE OR %MF_BYPOSITION)
' // Redraw the menu (this refreshes the caption bar, dimming the X button)
DrawMenuBar(hwnd)
END SUB
' ========================================================================================
I also have found some information about the undocumented API function Control_RunDLLW, that allows to launch control panel .cpl files, so I have written this one:
' ========================================================================================
' // Control_RunDLL is an undocumented procedure in the Shell32.dll which can be used
' // to launch control panel applications. You’ve to pass the name of the control panel
' // file (.cpl) and the tool represented by it will be launched. For launching some
' // control panel applications, you’ve to provide a valid windows handle (hwnd parameter)
' // and program instance (hinstance parameter).
' // This opens the control panel: AfxControlRunDLL(0, 0, "", %SW_SHOWNORMAL)
' // This opens the applications wizard: AfxControlRunDLL(0, 0, "appwiz.cpl", %SW_SHOWNORMAL)
' void WINAPI Control_RunDLLW(HWND hWnd, HINSTANCE hInst, LPCWSTR cmd, DWORD nCmdShow)
' ========================================================================================
SUB AfxControlRunDLL (BYVAL hwnd AS DWORD, BYVAL hInst AS DWORD, BYREF cmd AS WSTRINGZ, BYVAL nCmdShow AS DWORD) COMMON
LOCAL hLib AS DWORD
LOCAL pProc AS DWORD
hLib = LoadLibrary("shell32.dll")
IF hLib = %NULL THEN EXIT SUB
pProc = GetProcAddress(hLib, "Control_RunDLLW")
IF pProc THEN CALL DWORD pProc USING AfxControlRunDLL(hwnd, hInst, cmd, nCmdShow)
FreeLibrary hLib
END SUB
' ========================================================================================
Some like to make the LsitView header flat (if it was flat, they would make it 3D :) ), so I have added this function to the ListViewCtrl include file:
' ========================================================================================
' Removes the HDS_BUTTONS style from the header control to give it a flat appearance.
' ========================================================================================
SUB ListView_MakeHeaderFlat (BYVAL hwndLV AS DWORD)
LOCAL hLvHeader AS DWORD
hLvHeader = SendMessage(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT SUB
SetWindowLong hLvHeader, %GWL_STYLE, GetWindowLong(hLvHeader, %GWL_STYLE) XOR %HDS_BUTTONS
SetWindowPos GetParent(hwndLV), %NULL, 0, 0, 0, 0, %SWP_NOZORDER OR %SWP_NOMOVE OR %SWP_NOSIZE OR %SWP_DRAWFRAME
END SUB
' ========================================================================================
Sometimes, requests aren't so simple, such making the ListView header multiline. Several hacks have been used in the past, but no longer work with Windows 7. I have written a template (there is also a High DPI version) using my CWindow class:
' ########################################################################################
' Mutiline header ListView example
' The technique used is to process the HDM_LAYOUT message, fill the WINDOWPOS structure
' with the appropriate size and position of the header control, and change the top position
' of the rectangle that the header control will occupy.
' CASE %HDM_LAYOUT
' LOCAL phdl AS HDLAYOUT PTR
' phdl = lParam
' @phdl.@pwpos.hwnd = hwnd
' @phdl.@pwpos.flags = %SWP_FRAMECHANGED
' @phdl.@pwpos.x = @phdl.@prc.nLeft
' @phdl.@pwpos.y = 0
' @phdl.@pwpos.cx = @phdl.@prc.nRight - @phdl.@prc.nLeft
' @phdl.@pwpos.cy = 40 ' --> change me
' @phdl.@prc.nTop = 40 ' --> change me
' FUNCTION = -1
' EXIT FUNCTION
' ########################################################################################
#COMPILE EXE
#DIM ALL
#INCLUDE ONCE "CWindow.inc" ' // CWindow class
#INCLUDE ONCE "AfxStd.inc" ' // Standard library
#INCLUDE ONCE "ListViewCtrl.inc" ' // ListView control wrapper functions
#INCLUDE ONCE "HeaderCtrl.inc" ' // Header control wrapper functions
%IDC_LISTVIEW = 101
' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS DWORD, BYVAL hPrevInstance AS DWORD, BYVAL lpszCmdLine AS ASCIIZ PTR, BYVAL nCmdShow AS LONG) AS LONG
' // Create an instance of the class
LOCAL pWindow AS IWindow
pWindow = CLASS "CWindow"
IF ISNOTHING(pWindow) THEN EXIT FUNCTION
' // Create the main window
LOCAL hwnd AS DWORD
hwnd = pWindow.CreateWindow(%NULL, "Multiline Header ListView", 0, 0, 600, 350, -1, -1, CODEPTR(WindowProc))
' // Change the class style to avoid flicker
pWindow.ClassStyle = %CS_DBLCLKS
' // Center the window
pWindow.CenterWindow
' // Add a subclassed ListView control
LOCAL hListView AS DWORD
LOCAL rc AS RECT
GetClientRect hwnd, rc
LOCAL dwStyle AS DWORD
dwStyle = %WS_CHILD OR %WS_VISIBLE OR %LVS_REPORT OR %LVS_SINGLESEL OR %LVS_SHOWSELALWAYS
hListView = pWindow.AddListView(hwnd, %IDC_LISTVIEW, "", 0, 0, 0, 0, dwStyle, -1, CODEPTR(ListView_SubclassProc))
' // Add some extended styles
LOCAL dwExStyle AS DWORD
dwExStyle = ListView_GetExtendedListViewStyle(hListView)
dwExStyle = dwExStyle OR %LVS_EX_FULLROWSELECT OR %LVS_EX_GRIDLINES
ListView_SetExtendedListViewStyle(hListView, dwExStyle)
' // Get the handle of the ListView header control and subclass it
LOCAL hLvHeader AS DWORD
hLvHeader = ListView_GetHeader(hListView)
IF hLvHeader THEN SetProp hLvHeader, "OLDWNDPROC", SetWindowLong(hLvHeader, %GWL_WNDPROC, CODEPTR(ListViewHeader_SubclassProc))
' // Add the header's column names
ListView_AddColumn(hListView, 0, "Customer" & $CRLF & "number", 80, 1)
ListView_AddColumn(hListView, 1, "Name" & $CRLF & "First, last", 160, 0)
ListView_AddColumn(hListView, 2, "Telephone" & $CRLF & "number", 160, 0)
ListView_AddColumn(hListView, 3, "Street" & $CRLF & "address", 80, 0)
ListView_AddColumn(hListView, 4, "Action" & $CRLF & "items", 80, 1)
' // Populate the ListView with some data
ListView_AddItem(hListView, 0, 0, "1")
ListView_SetItemText(hListView, 0, 1, "Doe, John")
ListView_SetItemText(hListView, 0, 2, "(000) 000-0000")
ListView_SetItemText(hListView, 0, 3, "No name")
ListView_SetItemText(hListView, 0, 4, "Unknown")
ListView_AddItem(hListView, 1, 0, "2")
ListView_SetItemText(hListView, 1, 1, "Smith, Joe")
ListView_SetItemText(hListView, 1, 2, "(111) 111-1111")
ListView_SetItemText(hListView, 1, 3, "No name")
ListView_SetItemText(hListView, 1, 4, "Unknown")
' ... add more data
' // Force the resizing of the ListView by sending a WM_SIZE message
SendMessage hwnd, %WM_SIZE, 0, 0
' // Default message pump (you can replace it with your own)
pWindow.DoEvents
END FUNCTION
' ########################################################################################
' ========================================================================================
' Main callback function.
' ========================================================================================
FUNCTION WindowProc (BYVAL hwnd AS DWORD, BYVAL uMsg AS DWORD, BYVAL wParam AS DWORD, BYVAL lParam AS LONG) AS LONG
SELECT CASE uMsg
CASE %WM_COMMAND
SELECT CASE LO(WORD, wParam)
CASE %IDCANCEL
IF HI(WORD, wParam) = %BN_CLICKED THEN
SendMessage hwnd, %WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
END SELECT
CASE %WM_SIZE
' // Resize the ListView control and its header
IF wParam <> %SIZE_MINIMIZED THEN
LOCAL hListView AS DWORD
hListView = GetDlgItem(hwnd, %IDC_LISTVIEW)
MoveWindow hListView, 0, 0, LO(WORD, lParam), HI(WORD, lParam), %TRUE
MoveWindow ListView_GetHeader(hListView), 0, 0, LO(WORD, lParam), 40, %TRUE
END IF
CASE %WM_DESTROY
' // Close the main window
PostQuitMessage 0
EXIT FUNCTION
END SELECT
FUNCTION = DefWindowProc(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Processes messages for the subclassed ListView header control.
' ========================================================================================
FUNCTION ListViewHeader_SubclassProc ( _
BYVAL hwnd AS DWORD, _ ' // Control window handle
BYVAL uMsg AS DWORD, _ ' // Type of message
BYVAL wParam AS DWORD, _ ' // First message parameter
BYVAL lParam AS LONG _ ' // Second message parameter
) AS LONG
' // REQUIRED: Get the address of the original window procedure
LOCAL pOldWndProc AS DWORD
pOldWndProc = GetProp(hwnd, "OLDWNDPROC")
SELECT CASE uMsg
CASE %WM_DESTROY
' // REQUIRED: Remove control subclassing
SetWindowLong hwnd, %GWL_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
CASE %HDM_LAYOUT
' // Fill the WINDOWPOS structure with the appropriate size and position of the
' // header control and change the top position of the rectangle that the header
' // control will occupy.
LOCAL phdl AS HDLAYOUT PTR
phdl = lParam
@phdl.@pwpos.hwnd = hwnd
@phdl.@pwpos.flags = %SWP_FRAMECHANGED
@phdl.@pwpos.x = @phdl.@prc.Left
@phdl.@pwpos.y = 0
@phdl.@pwpos.cx = @phdl.@prc.Right - @phdl.@prc.Left
@phdl.@pwpos.cy = 40 ' --> change me
@phdl.@prc.nTop = 40 ' --> change me
FUNCTION = -1
EXIT FUNCTION
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Processes messages for the subclassed ListView control.
' ========================================================================================
FUNCTION ListView_SubclassProc ( _
BYVAL hwnd AS DWORD, _ ' // Control window handle
BYVAL uMsg AS DWORD, _ ' // Type of message
BYVAL wParam AS DWORD, _ ' // First message parameter
BYVAL lParam AS LONG _ ' // Second message parameter
) AS LONG
' // REQUIRED: Get the address of the original window procedure
LOCAL pOldWndProc AS DWORD
pOldWndProc = GetProp(hwnd, "OLDWNDPROC")
SELECT CASE uMsg
CASE %WM_DESTROY
' // REQUIRED: Remove control subclassing
SetWindowLong hwnd, %GWL_WNDPROC, RemoveProp(hwnd, "OLDWNDPROC")
CASE %WM_NOTIFY
LOCAL pnmh AS NMHDR PTR
LOCAL pnmcd AS NMCUSTOMDRAW PTR
LOCAL szText AS ASCIIZ * 260
pnmh = lParam
SELECT CASE @pnmh.code
CASE %NM_CUSTOMDRAW
pnmcd = lParam
' // Check the drawing stage
SELECT CASE @pnmcd.dwDrawStage
' // Prior to painting
CASE %CDDS_PREPAINT
' // Tell Windows we want individual notification of each item being drawn
FUNCTION = %CDRF_NOTIFYITEMDRAW
EXIT FUNCTION
' // Notification of each item being drawn
CASE %CDDS_ITEMPREPAINT
LOCAL hLvHeader AS DWORD
LOCAL nIndex AS DWORD
LOCAL nState AS DWORD
nIndex = @pnmcd.dwItemSpec
nState = @pnmcd.uItemState
' // Get the header item text...
LOCAL hdi AS HDITEM
hdi.mask = %HDI_TEXT
hdi.psztext = VARPTR(szText)
hdi.cchtextmax = SIZEOF(szText)
hLvHeader = ListView_GetHeader(hwnd)
Header_GetItem(hLvHeader, nIndex, hdi)
' // Create a new font
LOCAL hFont AS DWORD
hFont = AfxCreateFont("Tahoma", 10, %FW_BOLD, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
' // Select the font into the current devide context
LOCAL hOldFont AS DWORD
hOldFont = SelectObject(@pnmcd.hdc, hFont)
' // Draw the button state...
IF (nState AND %CDIS_SELECTED) THEN
DrawFrameControl @pnmcd.hdc, @pnmcd.rc, %DFC_BUTTON, %DFCS_BUTTONPUSH OR %DFCS_PUSHED
ELSE
DrawFrameControl @pnmcd.hdc, @pnmcd.rc, %DFC_BUTTON, %DFCS_BUTTONPUSH
END IF
' // Paint the background
LOCAL hBrush AS DWORD
hBrush = CreateSolidBrush(RGB(228,120,51))
InflateRect @pnmcd.rc, -2, -2
FillRect @pnmcd.hdc, @pnmcd.rc, hBrush
SetBkMode @pnmcd.hdc, %TRANSPARENT
' // Change your text color here...
SetTextColor @pnmcd.hdc, RGB(92,51,23)
' // Offset the text slightly if depressed...
IF (nState AND %CDIS_SELECTED) THEN InflateRect @pnmcd.rc, -2, -2
' // Draw multiline, using CRLF (i.e. szText = "Customer" & $CRLF & "number")
DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER 'OR %DT_WORDBREAK
' // Draw multiline using word wrap (i.e. szText = "Customer number")
'DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER OR %DT_WORDBREAK
' // Sraw single line with ellipsis... (i.e. szText = "Customer number")
'DrawText @pnmcd.hdc, szText, LEN(szText), @pnmcd.rc, %DT_CENTER OR %DT_VCENTER OR %DT_END_ELLIPSIS
' // Cleanup
IF hBrush THEN DeleteObject hBrush
IF hOldFont THEN SelectObject @pnmcd.hdc, hOldFont
IF hFont THEN DeleteObject hFont
' // Tell Windows the item has already been drawn
FUNCTION = %CDRF_SKIPDEFAULT
EXIT FUNCTION
END SELECT
END SELECT
END SELECT
FUNCTION = CallWindowProc(pOldWndProc, hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
Do you also have a routine to make the font in a ListView header bold?
Rolf
Jose,
All I can say is thank you. I saw the AFXxxxx in the new api. What does AFX stand for? They look like they do some very cool and useful things. Also, can you if you have time, explain or have a tutorial on when / how to use the High DPI routines. I've read bits here and there on your forum but haven't put it all together yet.
sorry if these are basic obvious questions. It sounds like the high DPI stuff is something Paul (FF4?) would need since it use for creating /drawing forms and controls and wouldn't mix well with FF3. I would be great if starting a program from scratch.
Looks like there are good things on the way. Thank you again
Doug
Jose is an unstopable force of nature. Making life easier for us programmers is something he does in such an unselfish way. Great job indeed.
I have been working on the FF4/PB10 code generation. I am still getting used to the whole unicode thing. It seems like I am doing more testing of code pieces then actual major work on the generator. Nonetheless, the goal is still to replace the current code generator with a PB10/Jose Includes/cWindow only solution.
Quote
Do you also have a routine to make the font in a ListView header bold?
It's easy to write if you have knowledge of Windows GDI.
' ========================================================================================
' Make the font used by the ListView header bold.
' Parameter:
' - hListView = Handle to the ListView
' Return Value:
' - Handle of the new font. You must delete it with DeleteObject when non longer needed.
' ========================================================================================
FUNCTION ListView_MakeHeaderFontBold (BYVAL hListView AS DWORD) AS DWORD
LOCAL hLvHeader AS DWORD
LOCAL hLvHeaderFont AS DWORD
LOCAL hCurrFont AS DWORD
LOCAL hOldFont AS DWORD
LOCAL lf AS LOGFONT
' // Get the handle of the header
hLvHeader = SendMessage(hListView, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
' // Get the handle of the font used by the header
hCurrFont = SendMessage(hLvHeader, %WM_GETFONT, 0, 0)
IF hCurrFont = 0 THEN EXIT FUNCTION
IF GetObject(hCurrFont, SIZEOF(lf), lf) THEN
lf.lfWeight = %FW_BOLD
hLvHeaderFont = CreateFontIndirect(lf)
IF hLvHeaderFont THEN
hOldFont = SelectObject(hLvHeader, hLvHeaderFont)
SendMessage(hLvHeader, %WM_SETFONT, hLvHeaderFont, %TRUE)
IF hOldFont THEN DeleteObject(hOldFont)
FUNCTION = hLvHeaderFont
END IF
END IF
END FUNCTION
' ========================================================================================
However, it isn't practical because you may want to also change other things, such both bold and italic, or the font face, etc., so I will write a ListView_SetHeaderFont allowing to change one or more of the characteristics of the font at the same time.
Thanks for the quick response, Jose.
I am looking foreward to it.
Rolf
Quote
What does AFX stand for?
Application Framework Extensions. I began using "API_", "PB_", etc., but as many people does the same, I have chosen a less obvious one to avoid conflicts.
Quote
Also, can you if you have time, explain or have a tutorial on when / how to use the High DPI routines. I've read bits here and there on your forum but haven't put it all together yet.
I too wasn't "High DPI aware" until I bought a high resolution monitor. The fonts of the High DPI aware applications, such the ones of the operating system and others such Office, were so small that I was unable to read them, so I increased the DPI of the fonts. Suddenly, the problems with the non High DPi aware applications began: Artifacts, fuzzy fonts, drag and drop not working properly, stretched graphics, etc.
It is not difficult to write High DPI aware applications, but it is tedious having to multiply all the pixel coordinates with a horizontal or vertical ratio. So I decided to modify the CWindow class to delegate the task to it.
You can read this MSDN tutorial: http://msdn.microsoft.com/en-us/library/dd464659%28VS.85%29.aspx
It is an important subject because soon Windows 7 will become the dominant OS and high resolution monitors the norm.
CWindow also works with unicode transparently. You use the same names for the API functions, and the "W" versions will be called if you have defined %UNICODE = 1 before adding the includes. Because Windows has been written using unicode and the "A" functions are simply wrappers that convert the string parameters to unicode and call the "W" function, working with WSTRINGs and WSTRINGZs instead of STRINGs and ASCIIZs is somewhat faster and gives you additional advantages, like support for foreign languages. For new applications, my advice is to use unicode strings and reserve the use of STRINGs and ASCIIZs only when needed, such calling a third party API that doesn't support unicode or using it as a buffer for binary data.
It is also important for Paul, because as DDT is now unicode and, as it uses the Windows Dialog Engine, Windows takes care of High DPI and does the scaling. And I don't think that Paul will be happy seeing PBer's using DDT instead of FF.
What I'm doing with the classes and wrappers is to provide a sort of DDT for SDK programmers, but without the limitations of the Windows Dialog Engine.
About extending the language, besides the wrapper functions, the CVarUtils helper class provides about 120 methods to deal with variants, providing all the functionality still missing in PB. There is also a class, CPropVarUtils, to deal with PROPVARIANTs, a data type not natively supported by PB, which is very important to work with some new Windows 7 technologies.
Quote from: Jose Roca on April 15, 2011, 02:36:45 PM
Application Framework Extensions. I began using "API_", "PB_", etc., but as many people does the same, I have chosen a less obvious one to avoid conflicts.
Careful, your MFC is showing! Application Framework Extensions was the original name for the Microsoft Foundation Classes, circa 1992. It really caught on when Visual C++ was released a year or so later.
Maybe little by little I will end writing PBC (PowerBASIC Foundation classes) :) The way I have dessigned the class will allow it, yet making it optional. I could add Create methods that will create an instance of the, e.g. CListView class instead of using CreateWindowEx, and pass a pointer to the CWindow class to allow it to access the data of this class (I'm a COM programmer, not an OOPer, so don't use inheritance, polymorphism, etc.). A collection of object references will keep the objects alive without having to use globals and will do automatic garbage collection. I have started with a class to deal with image lists. Next, I want to write one for fonts. Later, we will see...
QuoteJose is an unstopable force of nature.
I agree 1000%
Doug
This function allows to set the font of a litview header.
' ========================================================================================
' Change the font used by the listview header.
' Examples of Use:
' hFont = ListView_SetHeaderFontA(hListView, "MS Sans Serif", 8, %FW_NORMAL, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
' hFont = ListView_SetHeaderFontA(hListView, "Courier New", 10, %FW_BOLD, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
' hFont = ListView_SetHeaderFontA(hListView, "Marlett", 8, %FW_NORMAL, %FALSE, %FALSE, %FALSE, %SYMBOL_CHARSET)
' Note: The returned font must be destroyed with DeleteObject when no longer needed to prevent memory leaks.
' ========================================================================================
FUNCTION ListView_SetHeaderFontA ( _
BYVAL hListView AS DWORD, _ ' __in Handle to the listview
BYVAL strFaceName AS STRING, _ ' __in Typeface name of font
BYVAL lPointSize AS LONG, _ ' __in Point size
BYVAL lWeight AS LONG, _ ' __in Font weight(bold etc.)
BYVAL bItalic AS BYTE, _ ' __in TRUE = italic
BYVAL bUnderline AS BYTE, _ ' __in TRUE = underline
BYVAL bStrikeOut AS BYTE, _ ' __in TRUE = strikeout
BYVAL bCharSet AS BYTE _ ' __in character set
) AS DWORD ' Handle of font or NULL on failure.
LOCAL hLvHeader AS DWORD
LOCAL hLvHeaderFont AS DWORD
LOCAL hCurFont AS DWORD
LOCAL hOldFont AS DWORD
LOCAL lf AS LOGFONTA
LOCAL hDC AS DWORD
' // Get the handle of the header
hLvHeader = SendMessageA(hListView, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
' // Create the font
hDC = GetDC(%HWND_DESKTOP)
lf.lfHeight = -MulDiv(lPointSize, GetDeviceCaps(hDC, %LOGPIXELSY), 72) ' logical font height
lf.lfWidth = 0 ' average character width
lf.lfEscapement = 0 ' escapement
lf.lfOrientation = 0 ' orientation angles
lf.lfWeight = lWeight ' font weight
lf.lfItalic = bItalic ' italic(TRUE/FALSE)
lf.lfUnderline = bUnderline ' underline(TRUE/FALSE)
lf.lfStrikeOut = bStrikeOut ' strikeout(TRUE/FALSE)
lf.lfCharSet = bCharset ' character set
lf.lfOutPrecision = %OUT_TT_PRECIS ' output precision
lf.lfClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
lf.lfQuality = %DEFAULT_QUALITY ' output quality
lf.lfPitchAndFamily = %FF_DONTCARE ' pitch and family
lf.lfFaceName = strFaceName ' typeface name
ReleaseDC %HWND_DESKTOP, hDC
hLvHeaderFont = CreateFontIndirectA(lf)
IF hLvHeaderFont = 0 THEN EXIT FUNCTION
' // Select the font
hOldFont = SelectObject(hLvHeader, hLvHeaderFont)
SendMessageA(hLvHeader, %WM_SETFONT, hLvHeaderFont, %TRUE)
IF hOldFont THEN DeleteObject(hOldFont)
FUNCTION = hLvHeaderFont
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION ListView_SetHeaderFontW ( _
BYVAL hListView AS DWORD, _ ' __in Handle to the listview
BYVAL strFaceName AS WSTRING, _ ' __in Typeface name of font
BYVAL lPointSize AS LONG, _ ' __in Point size
BYVAL lWeight AS LONG, _ ' __in Font weight(bold etc.)
BYVAL bItalic AS BYTE, _ ' __in TRUE = italic
BYVAL bUnderline AS BYTE, _ ' __in TRUE = underline
BYVAL bStrikeOut AS BYTE, _ ' __in TRUE = strikeout
BYVAL bCharSet AS BYTE _ ' __in character set
) AS DWORD ' Handle of font or NULL on failure.
LOCAL hLvHeader AS DWORD
LOCAL hLvHeaderFont AS DWORD
LOCAL hOldFont AS DWORD
LOCAL lf AS LOGFONTW
LOCAL hDC AS DWORD
' // Get the handle of the header
hLvHeader = SendMessageW(hListView, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
' // Create the font
hDC = GetDC(%HWND_DESKTOP)
lf.lfHeight = -MulDiv(lPointSize, GetDeviceCaps(hDC, %LOGPIXELSY), 72) ' logical font height
lf.lfWidth = 0 ' average character width
lf.lfEscapement = 0 ' escapement
lf.lfOrientation = 0 ' orientation angles
lf.lfWeight = lWeight ' font weight
lf.lfItalic = bItalic ' italic(TRUE/FALSE)
lf.lfUnderline = bUnderline ' underline(TRUE/FALSE)
lf.lfStrikeOut = bStrikeOut ' strikeout(TRUE/FALSE)
lf.lfCharSet = bCharset ' character set
lf.lfOutPrecision = %OUT_TT_PRECIS ' output precision
lf.lfClipPrecision = %CLIP_DEFAULT_PRECIS ' clipping precision
lf.lfQuality = %DEFAULT_QUALITY ' output quality
lf.lfPitchAndFamily = %FF_DONTCARE ' pitch and family
lf.lfFaceName = strFaceName ' typeface name
ReleaseDC %HWND_DESKTOP, hDC
hLvHeaderFont = CreateFontIndirectW(lf)
IF hLvHeaderFont = 0 THEN EXIT FUNCTION
' // Select the font
hOldFont = SelectObject(hLvHeader, hLvHeaderFont)
SendMessageW(hLvHeader, %WM_SETFONT, hLvHeaderFont, %TRUE)
IF hOldFont THEN DeleteObject(hOldFont)
FUNCTION = hLvHeaderFont
END FUNCTION
' ========================================================================================
#IF %DEF(%UNICODE)
MACRO ListView_SetHeaderFont = ListView_SetHeaderFontW
#ELSE
MACRO ListView_SetHeaderFont = ListView_SetHeaderFontA
#ENDIF
Beautiful - thank you very much Josè!
I think PBC42 is on the brink.
Rolf
And this one allows to change selected values only, e.g. hFont = ListView_ModifyHeaderFontA(hListView, "", 0, %FW_BOLD) to make the font bold.
' ========================================================================================
' Modifies the font used by the listview header.
' Only the passed values that are not an empty string or zero will be modified.
' Note: The returned font must be destroyed with DeleteObject when no longer needed to prevent memory leaks.
' ========================================================================================
FUNCTION ListView_ModifyHeaderFontA ( _
BYVAL hListView AS DWORD, _ ' __in Handle to the listview
BYVAL strFaceName AS STRING, _ ' __in Typeface name of font
OPTIONAL BYVAL lPointSize AS LONG, _ ' __in Point size
BYVAL lWeight AS LONG, _ ' __in Font weight(bold etc.)
BYVAL bItalic AS BYTE, _ ' __in TRUE = italic
BYVAL bUnderline AS BYTE, _ ' __in TRUE = underline
BYVAL bStrikeOut AS BYTE, _ ' __in TRUE = strikeout
BYVAL bCharSet AS BYTE _ ' __in character set
) AS DWORD ' Handle of font or NULL on failure.
LOCAL hLvHeader AS DWORD
LOCAL hLvHeaderFont AS DWORD
LOCAL hCurFont AS DWORD
LOCAL hOldFont AS DWORD
LOCAL lf AS LOGFONTA
LOCAL hDC AS DWORD
' // Get the handle of the header
hLvHeader = SendMessageA(hListView, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
' // Get the handle of the font used by the header
hCurFont = SendMessageA(hLvHeader, %WM_GETFONT, 0, 0)
IF hCurFont = 0 THEN EXIT FUNCTION
' // Get the LOGFONT structure
IF GetObjectA(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION
' // Change the requested values
IF lPointSize THEN
hDC = GetDC(%HWND_DESKTOP)
lf.lfHeight = -MulDiv(lPointSize, GetDeviceCaps(hDC, %LOGPIXELSY), 72)
ReleaseDC %HWND_DESKTOP, hDC
END IF
IF lWeight THEN lf.lfWeight = lWeight
IF bItalic THEN lf.lfItalic = bItalic
IF bUnderline THEN lf.lfUnderline = bUnderline
IF bStrikeOut THEN lf.lfStrikeOut = bStrikeOut
IF bCharset THEN lf.lfCharSet = bCharset
IF strFaceName <> "" THEN lf.lfFaceName = strFaceName
' // Create the font
hLvHeaderFont = CreateFontIndirectA(lf)
IF hLvHeaderFont = 0 THEN EXIT FUNCTION
' // Select the font
hOldFont = SelectObject(hLvHeader, hLvHeaderFont)
SendMessageA(hLvHeader, %WM_SETFONT, hLvHeaderFont, %TRUE)
IF hOldFont THEN DeleteObject(hOldFont)
FUNCTION = hLvHeaderFont
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION ListView_ModifyHeaderFontW ( _
BYVAL hListView AS DWORD, _ ' __in Handle to the listview
BYVAL strFaceName AS STRING, _ ' __in Typeface name of font
OPTIONAL BYVAL lPointSize AS LONG, _ ' __in Point size
BYVAL lWeight AS LONG, _ ' __in Font weight(bold etc.)
BYVAL bItalic AS BYTE, _ ' __in TRUE = italic
BYVAL bUnderline AS BYTE, _ ' __in TRUE = underline
BYVAL bStrikeOut AS BYTE, _ ' __in TRUE = strikeout
BYVAL bCharSet AS BYTE _ ' __in character set
) AS DWORD ' Handle of font or NULL on failure.
LOCAL hLvHeader AS DWORD
LOCAL hLvHeaderFont AS DWORD
LOCAL hCurFont AS DWORD
LOCAL hOldFont AS DWORD
LOCAL lf AS LOGFONTW
LOCAL hDC AS DWORD
' // Get the handle of the header
hLvHeader = SendMessageW(hListView, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
' // Get the handle of the font used by the header
hCurFont = SendMessageW(hLvHeader, %WM_GETFONT, 0, 0)
IF hCurFont = 0 THEN EXIT FUNCTION
' // Get the LOGFONT structure
IF GetObjectW(hCurFont, SIZEOF(lf), lf) = 0 THEN EXIT FUNCTION
' // Change the requested values
IF lPointSize THEN
hDC = GetDC(%HWND_DESKTOP)
lf.lfHeight = -MulDiv(lPointSize, GetDeviceCaps(hDC, %LOGPIXELSY), 72)
ReleaseDC %HWND_DESKTOP, hDC
END IF
IF lWeight THEN lf.lfWeight = lWeight
IF bItalic THEN lf.lfItalic = bItalic
IF bUnderline THEN lf.lfUnderline = bUnderline
IF bStrikeOut THEN lf.lfStrikeOut = bStrikeOut
IF bCharset THEN lf.lfCharSet = bCharset
IF strFaceName <> "" THEN lf.lfFaceName = strFaceName
' // Create the font
hLvHeaderFont = CreateFontIndirectW(lf)
IF hLvHeaderFont = 0 THEN EXIT FUNCTION
' // Select the font
hOldFont = SelectObject(hLvHeader, hLvHeaderFont)
SendMessageW(hLvHeader, %WM_SETFONT, hLvHeaderFont, %TRUE)
IF hOldFont THEN DeleteObject(hOldFont)
FUNCTION = hLvHeaderFont
END FUNCTION
' ========================================================================================
#IF %DEF(%UNICODE)
MACRO ListView_ModifyHeaderFont = ListView_ModifyHeaderFontW
#ELSE
MACRO ListView_ModifyHeaderFont = ListView_ModifyHeaderFontA
#ENDIF
Other new ListView wrappers:
' ========================================================================================
' Automatically sizes the specified column.
' ========================================================================================
FUNCTION ListView_FitContent (BYVAL hwndLV AS DWORD, BYVAL iCol AS LONG) AS LONG
FUNCTION = SendMessage(hwndLV, %LVM_SETCOLUMNWIDTH, iCol, %LVSCW_AUTOSIZE)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Automatically sizes all the columns of a listview
' ========================================================================================
FUNCTION ListView_AutoSizeColumns (BYVAL hwndLV AS DWORD) AS LONG
LOCAL i, nCount AS LONG, hLvHeader AS DWORD
hLvHeader = SendMessage(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
nCount = SendMessage(hLvHeader, %HDM_GETITEMCOUNT, 0, 0)
FOR i = 0 TO nCount - 1
FUNCTION = SendMessage(hwndLV, %LVM_SETCOLUMNWIDTH, i, %LVSCW_AUTOSIZE)
NEXT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Automatically sizes the column to fit the header text. If you use this value with the
' last column, its width is set to fill the remaining width of the list-view control.
' ========================================================================================
FUNCTION ListView_FitHeader (BYVAL hwndLV AS DWORD, BYVAL iCol AS LONG) AS LONG
FUNCTION = SendMessage(hwndLV, %LVM_SETCOLUMNWIDTH, iCol, %LVSCW_AUTOSIZE_USEHEADER)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Automatically sizes all the columns of the header of a listview
' ========================================================================================
FUNCTION ListView_AutoSizeHeader (BYVAL hwndLV AS DWORD) AS LONG
LOCAL i, nCount AS LONG, hLvHeader AS DWORD
hLvHeader = SendMessage(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
nCount = SendMessage(hLvHeader, %HDM_GETITEMCOUNT, 0, 0)
FOR i = 0 TO nCount - 1
FUNCTION = SendMessage(hwndLV, %LVM_SETCOLUMNWIDTH, i, %LVSCW_AUTOSIZE_USEHEADER)
NEXT
END FUNCTION
' ========================================================================================
' ========================================================================================
' Gets the number of columns of a listview.
' ========================================================================================
FUNCTION ListView_GetColumnCount (BYVAL hwndLV AS DWORD) AS LONG
LOCAL hLvHeader AS DWORD
hLvHeader = SendMessage(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
FUNCTION = SendMessage(hLvHeader, %HDM_GETITEMCOUNT, 0, 0)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Gets the text of the specified column of the header of a listview control.
' ========================================================================================
FUNCTION ListView_GetHeaderTextA (BYVAL hwndLV AS DWORD, BYVAL iCol AS LONG, OPTIONAL BYVAL cchTextMax AS LONG) AS STRING
LOCAL hLvHeader AS DWORD
hLvHeader = SendMessageA(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
LOCAL strText AS STRING
IF cchTextMax < 1 THEN cchTextMax = %MAX_PATH + 1
strText = SPACE$(cchTextMax + 1)
LOCAL hdi AS HDITEMA
hdi.mask = %HDI_TEXT
hdi.cchTextMax = cchTextMax + 1
hdi.pszText = STRPTR(strText)
IF SendMessageA(hLvHeader, %HDM_GETITEMA, iCol, VARPTR(hdi)) THEN FUNCTION = strText
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION ListView_GetHeaderTextW (BYVAL hwndLV AS DWORD, BYVAL iCol AS LONG, OPTIONAL BYVAL cchTextMax AS LONG) AS WSTRING
LOCAL hLvHeader AS DWORD
hLvHeader = SendMessageW(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
LOCAL bstrText AS WSTRING
IF cchTextMax < 1 THEN cchTextMax = %MAX_PATH + 1
bstrText = SPACE$(cchTextMax + 1)
LOCAL hdi AS HDITEMW
hdi.mask = %HDI_TEXT
hdi.cchTextMax = cchTextMax + 1
hdi.pszText = STRPTR(bstrText)
IF SendMessageW(hLvHeader, %HDM_GETITEMW, iCol, VARPTR(hdi)) THEN FUNCTION = bstrText
END FUNCTION
' ========================================================================================
#IF %DEF(%UNICODE)
MACRO ListView_GetHeaderText = ListView_GetHeaderTextW
#ELSE
MACRO ListView_GetHeaderText = ListView_GetHeaderTextA
#ENDIF
' ========================================================================================
' Gets the order of the specified column of the listview's header control.
' ========================================================================================
FUNCTION ListView_GetColumnOrder (BYVAL hwndLV AS DWORD, BYVAL iCol AS LONG) AS LONG
LOCAL hLvHeader AS DWORD
hLvHeader = SendMessageW(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
LOCAL hdi AS HDITEM
hdi.mask = %HDI_ORDER
IF SendMessage(hLvHeader, %HDM_GETITEM, iCol, VARPTR(hdi)) THEN FUNCTION = hdi.iOrder
END FUNCTION
' ========================================================================================
' ========================================================================================
' Gets the current left-to-right order of items in the header of a listview control.
' ========================================================================================
FUNCTION ListView_GetOrderArray (BYVAL hwndLV AS DWORD, BYVAL iSize AS DWORD, BYREF lpiArray AS LONG) AS LONG
LOCAL hLvHeader AS DWORD
hLvHeader = SendMessageW(hwndLV, %LVM_GETHEADER, 0, 0)
IF hLvHeader = 0 THEN EXIT FUNCTION
FUNCTION = SendMessage(hLvHeader, %HDM_GETORDERARRAY, iSize, VARPTR(lpiArray))
END FUNCTION
' ========================================================================================
There will be many more wrappers in the next update. For example, someone asked don't remember where how to know if a program has been launched from a shortcut.
' ========================================================================================
' Returns TRUE if the application has been started through a shortcut; FALSE if not.
' ========================================================================================
FUNCTION AfxStartedFromShortcut () AS LONG
LOCAL si AS STARTUPINFO
GetStartupInfo(si)
IF (si.dwFlags AND %STARTF_TITLEISLINKNAME) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns the name of the shortcut used to start the application.
' ========================================================================================
FUNCTION AfxStartedFromShortcutNameA () AS STRING
LOCAL si AS STARTUPINFO
GetStartupInfoA(si)
IF (si.dwFlags AND %STARTF_TITLEISLINKNAME) THEN FUNCTION = si.@lpTitle
END FUNCTION
' ========================================================================================
' ========================================================================================
FUNCTION AfxStartedFromShortcutNameW () AS WSTRING
LOCAL si AS STARTUPINFO
GetStartupInfoW(si)
IF (si.dwFlags AND %STARTF_TITLEISLINKNAME) THEN FUNCTION = si.@lpTitle
END FUNCTION
' ========================================================================================
#IF %DEF(%UNICODE)
MACRO AfxStartedFromShortcutName = AfxStartedFromShortcutNameW
#ELSE
MACRO AfxStartedFromShortcutName = AfxStartedFromShortcutNameA
#ENDIF
Several menu wrappers to add to the existing ones:
' ========================================================================================
' Toggles the checked state of a menu item.
' ========================================================================================
FUNCTION ToggleMenuItem (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
IF GetMenuState(hMenu, uItem, dwFlags) AND %MF_CHECKED = %MF_CHECKED THEN
dwFlags = dwFlags OR %MF_UNCHECKED
ELSE
dwFlags = dwFlags OR %MF_CHECKED
END IF
FUNCTION = CheckMenuItem(hMenu, uItem, dwFlags)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is checked; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemChecked (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
IF GetMenuState(hMenu, uItem, dwFlags) AND %MF_CHECKED = %MF_CHECKED THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is enabled; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemEnabled (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_DISABLED) <> %MF_DISABLED) AND ((dwRes AND %MF_GRAYED) <> %MF_GRAYED) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is disabled; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemDisabled (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_DISABLED) = %MF_DISABLED) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is grayed; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemGrayed (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_GRAYED) = %MF_GRAYED) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is highlighted; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemHighlighted (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_HILITE) = %MF_HILITE) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is a separator; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemSeparator (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_SEPARATOR) = %MF_SEPARATOR) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is a submenu; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemPopup (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_POPUP) = %MF_POPUP) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Returns TRUE if the specified menu item is ownerdraw; FALSE otherwise.
' ========================================================================================
FUNCTION AfxIsMenuItemOwnerDraw (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL dwFlags, dwRes AS DWORD
IF fByPosition THEN dwFlags = %MF_BYPOSITION ELSE dwFlags = %MF_BYCOMMAND
dwRes = GetMenuState(hMenu, uItem, dwFlags)
IF ((dwRes AND %MF_OWNERDRAW) = %MF_OWNERDRAW) THEN FUNCTION = %TRUE
END FUNCTION
' ========================================================================================
' ========================================================================================
' Enables the specified menu item.
' ========================================================================================
FUNCTION AfxEnableMenuItem (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = %MIIM_STATE
mii.fState = %MFS_ENABLED
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Disables the specified menu item.
' ========================================================================================
FUNCTION AfxDisableMenuItem (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = %MIIM_STATE
mii.fState = %MFS_DISABLED
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Grays the specified menu item.
' ========================================================================================
FUNCTION AfxGrayMenuItem (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = %MIIM_STATE
mii.fState = %MFS_GRAYED
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Highlights the specified menu item.
' ========================================================================================
FUNCTION AfxHiliteMenuItem (BYVAL hMenu AS DWORD, BYVAL uItem AS DWORD, OPTIONAL BYVAL fByPosition AS LONG) AS LONG
LOCAL mii AS MENUITEMINFOW
mii.cbSize = SIZEOF(mii)
mii.fMask = %MIIM_STATE
mii.fState = %MFS_HILITE
FUNCTION = SetMenuItemInfoW(hMenu, uItem, fByPosition, mii)
END FUNCTION
' ========================================================================================
' ========================================================================================
' Calculates the size of a menu bar or a drop-down menu.
' - hwnd = Handle of the window that owns the menu.
' - hmenu = handle of the menu.
' - rcmenu = Pointer to a variable of type RECT where to return the retrieved values.
' Return Value:
' If the function succeeds, the return value is 0.
' If the function fails, the return value is a system error code.
' ========================================================================================
FUNCTION AfxGetMenuRect (BYVAL hwnd AS DWORD, BYVAL hmenu AS DWORD, BYREF rcmenu AS RECT) AS LONG
LOCAL i AS LONG, nRes AS LONG, rc AS RECT
FOR i = 1 TO GetMenuItemCount(hmenu)
nRes = GetMenuItemRect(hwnd, hmenu, i, rc)
IF nRes = -1 THEN nRes = GetLastError : EXIT FOR
UnionRect rcmenu, rcmenu, rc
NEXT
FUNCTION = nRes
END FUNCTION
' ========================================================================================
A new method for the CWindow class:
' =====================================================================================
' Adds a rebar control with an embedded toolbar to the window.
' =====================================================================================
#IF %DEF(%UNICODE)
METHOD AddToolbarRebar (BYVAL hParent AS DWORD, BYVAL cID AS LONG, BYVAL hToolbar AS DWORD, BYVAL strTitle AS WSTRING, _
BYVAL x AS LONG, BYVAL y AS LONG, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _
OPTIONAL BYVAL dwStyle AS DWORD, BYVAL dwExStyle AS DWORD, BYVAL pWndProc AS DWORD, BYVAL bNoScale AS LONG) AS DWORD
#ELSE
METHOD AddToolbarRebar (BYVAL hParent AS DWORD, BYVAL cID AS LONG, BYVAL hToolbar AS DWORD, BYVAL strTitle AS STRING, _
BYVAL x AS LONG, BYVAL y AS LONG, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG, _
OPTIONAL BYVAL dwStyle AS DWORD, BYVAL dwExStyle AS DWORD, BYVAL pWndProc AS DWORD, BYVAL bNoScale AS LONG) AS DWORD
#ENDIF
LOCAL hCtl AS DWORD
IF dwStyle = 0 OR BITS(LONG, dwStyle) = -1 THEN dwStyle = %WS_VISIBLE OR %WS_BORDER OR %WS_CLIPCHILDREN OR %WS_CLIPSIBLINGS OR %CCS_NODIVIDER OR %RBS_AUTOSIZE
IF BITS(LONG, dwExStyle) = -1 THEN dwExStyle = 0
' // Make sure that the control has the WS_CHILD style
dwStyle = dwStyle OR %WS_CHILD
hCtl = ME.AddControl ("ReBarWindow32", hParent, cID, strTitle, x, y, nWidth, nHeight, dwStyle, dwExStyle, %NULL, pWndProc, bNoScale)
IF hCtl = %NULL THEN EXIT METHOD
SendMessage hCtl, %WM_SETFONT, m_hFont, %TRUE
' // Make sure the toolbar has the right styles
SetWindowLong hToolbar, %GWL_STYLE, GetWindowLong(hToolbar, %GWL_STYLE) OR %CCS_NODIVIDER OR %CCS_NORESIZE OR %CCS_NOPARENTALIGN
' // The size of the REBARBANDINFO is different in Vista/Windows 7
LOCAL trbbi AS REBARBANDINFO
IF AfxGetWindowsVersion => 6.00 AND AfxGetComCtlVersion => 6.00 THEN
trbbi.cbSize = %REBARBANDINFO_V6_SIZE
ELSE
trbbi.cbSize = %REBARBANDINFO_V3_SIZE
END IF
trbbi.fMask = %RBBIM_STYLE OR %RBBIM_CHILD OR %RBBIM_CHILDSIZE OR _
%RBBIM_SIZE OR %RBBIM_ID OR %RBBIM_IDEALSIZE
trbbi.fStyle = %RBBS_CHILDEDGE ' OR %RBBS_GRIPPERALWAYS
trbbi.hwndChild = hToolbar
trbbi.cxMinChild = 0
trbbi.cyMinChild = HI(WORD, SendMessage(hToolBar, %TB_GETBUTTONSIZE, 0, 0))
trbbi.cx = ME.ClientWidth
trbbi.wID = 0
trbbi.cxIdeal = ME.ClientWidth
SendMessage (hCtl, %RB_INSERTBAND, -1, VARPTR(trbbi))
METHOD = hCtl
END METHOD
' =====================================================================================
I'm also writing a template for an help browser application. See attached picture.
It uses instances of the web browser control for the banner and to display the html pages.
The toolbar-rebar uses the new method AddToolbarRebar.
Demonstrates the use of most commands of the web browser control: Go Back, Go Forward, Find, Properties, Refresh, Stop, Optical zoom, Page Setup, Print, Print Preview, Save as HTML, txt or mht.
With HTML5 we can have fast graphics and animations too.
Quote from: Jose Roca on August 09, 2011, 08:32:16 AM
With HTML5 we can have fast graphics and animations too.
Wow! Now all I need is a ribbon control.
Rick
Jose,
I've been copying any AFX functions I see you post here, but wondered if you have a "central repository", like your headers, where I can download them all (in either source, SLL, DLL, or PBLIB format)???
Thx! : )
All these, and many more, will be incorporated in the next update of my Windows API Headers, so you don't need to collect them. I post them as an advance.
If someone has suggestions for new wrappers, please let me know.
BTW I'm using include files only (no DLLs, SLLs or PBLIBs) because they allow conditional compilation. SLLs are useful to third party programmers to hide the code, but I have nothing to hide.
We appreciate that, Josè!
(yes, Jose, much thx!!)
Jose - Dude, you're amazing. Don't know what we would do without you.
As I said, dead code removal is all I needed to extend the language. I noticed that DDT had two statements, LISTVIEW FIT HEADER and LISTVIEW FIT CONTENTS, for which I had not an equivalent wrapper, and I wrote ListView_FitHeader and ListView_FitContent. Then I went beyond and added ListView_AutoSizeColumns, ListView_AutoSizeHeader and several more.
With the new ODBC class, I have made the use of ODBC as easy as ADO:
' ########################################################################################
' Microsoft Windows
' File: CODBCEX_BasicSteps.bas
' Contents: CODBC class example
' Demonstrates the basic steps to use the CODBC class to connect to a database, execute a
' query and fetch the results.
' Compilers: PBWIN 10+, PBCC 6+
' Headers: Windows API headers 2.03+
' Copyright (c) 2011 Jose Roca. Freeware. Use at your own risk.
' Portions Copyright (c) Microsoft Corporation. All Rights Reserved.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################
' CSED_PBCC - Use the PBCC compiler
#COMPILE EXE
#DIM ALL
#INCLUDE "CODBC.INC"
' ========================================================================================
' Main
' ========================================================================================
FUNCTION PBMAIN
' // Create an instance of the class
LOCAL pOdbc AS IOdbc
pOdbc = NewOdbc(%SQL_OV_ODBC3_80)
IF ISNOTHING(pOdbc) THEN EXIT FUNCTION
TRY
' // Create a connection object
LOCAL pCon AS IOdbcConnection
pCon = pOdbc.Connection("Connection1")
' // Open the database
pCon.OpenDatabase("DRIVER={Microsoft Access Driver (*.mdb)};DBQ=biblio.mdb;UID=;PWD=;")
' // Allocate an statement object
LOCAL pStmt AS IOdbcStatement
pStmt = pCon.Statement("Statement1")
' // Cursor type
pStmt.SetMultiuserKeysetCursor
' // Generate a result set
pStmt.ExecDirect ("SELECT TOP 20 * FROM Authors ORDER BY Author")
' // Parse the result set
LOCAL strOutput AS STRING
DO
' // Fetch the record
IF ISFALSE pStmt.Fetch THEN EXIT DO
' // Get the values of the columns and display them
strOutput = ""
strOutput += pStmt.GetDataString(1) & " "
strOutput += pStmt.GetDataString(2) & " "
strOutput += pStmt.GetDataString(3)
STDOUT strOutput
' // Note: Instead of retrieving the data by ordinal,
' // you can also do it by column name.
' strOutput = ""
' strOutput += pStmt.GetDataString("Au_ID") & " "
' strOutput += pStmt.GetDataString("Author") & " "
' strOutput += pStmt.GetDataString("Year Born")
' STDOUT strOutput
LOOP
CATCH
' // Display error information
STDOUT OdbcOleErrorInfo(OBJRESULT)
WAITKEY$
END TRY
' // Destroy the class
pOdbc = NOTHING
WAITKEY$
END FUNCTION
' ========================================================================================
A similar one could be written for SQLite.