I would like to determine if a particular string would fit in a form's caption without truncation. How would I go about determining that?
Printable View
I would like to determine if a particular string would fit in a form's caption without truncation. How would I go about determining that?
That's not an easy thing to determine, as you need to find out various things about the current Windows theme - such as which font is being used, what the form borders are, and if your form has them what the size/position of the icon and min/max/close buttons are.
I think you can find those things out using GetSystemMetrics
It is something that I haven't done myself, as Windows automatically truncates (with ellipses) a caption if needed, but still shows the full title when you hover over the taskbar... but I guess for an MDI child the situation changes a bit.
Yup I know that Windows automatically truncates captions but what I'd like to do isQuote:
Originally Posted by si_the_geek
C:\Documents and Settings\Martin Liss\My Documents\My Pictures\2008-05 Italy\...\IMG_3376.JPG
which is the way Word does it when the path is too long.
Some time ago I developed this routine which works if you give it a known width (intLimit).
It works for me if I do the followingCode:Public Function ShortenCaption(strText As String, intLimit As Integer) As String
'***************************************************************************
'Purpose: Shorten a path name the way Word does when the path is too long
'Inputs: strText - The full path name
' intLimit - The maximum length for the path
'Outputs: The possibly shortened path name
'***************************************************************************
Dim strFileName As String
Dim strPath As String
Const DOTDOTDOT$ = "\...\"
Const BEVIL_WIDTH = 90
On Error GoTo ErrorRoutine
If TextWidth(strText) <= intLimit - BEVIL_WIDTH Then
ShortenCaption = strText
Exit Function
End If
strFileName = Mid$(strText, InStrRev(strText, "\") + 1)
strPath = Left$(strText, InStrRev(strText, "\") - 1)
Do
strPath = Left$(strText, InStrRev(strPath, "\") - 1)
Loop While TextWidth(strPath & DOTDOTDOT & strFileName) > intLimit - BEVIL_WIDTH
ShortenCaption = strPath & DOTDOTDOT & strFileName
Exit Function
ErrorRoutine:
If Err.Number = 5 Then
ShortenCaption = strText
Else
MsgBox Err.Number & " - " & Err.Description & " in ShortenCaption"
End If
End Function
but I'm afraid that it may not work as well on someone else's PC. Your advice about GetSystemMetrics is interesting but I don't think it gives me what I need. I ran a test using the following codeCode:Me.Caption = ShortenCaption("The text I want to put in the caption", ScaleWidth - 3800)
My form's scalemode is Twips so I converted the pixel outputs of the API and doing so I get 375, 240 and 255 and even if I multiply the largest (375) by 4 (for the form's icon and 3 controlbox buttons) I only get 1500 which is significantly less than my 3800 fudge factor.Code:Debug.Print GetSystemMetrics(SM_CXSIZE) * Screen.TwipsPerPixelX
Debug.Print GetSystemMetrics(SM_CXSMICON) * Screen.TwipsPerPixelX
Debug.Print GetSystemMetrics(SM_CXSMSIZE) * Screen.TwipsPerPixelX
The API GetTitleBarInfo may be what you want. This returns various info including the length of the caption area + the minimise, restore, maximise buttons (the form icon is not included). As these are squares, you can use the titlebar height to calculate the "writeable" length - depending on which buttons the form has.
After this, you could use an out-of-view autosize label set to the same font as the form caption to determine the "real" length - then set the form's caption to your pre-determined rules. (EDIT: Maybe even show a 'tooltip')
API Guide has a GetTitleBarInfo example.
I just tried it (in XP, default theme) and it seems right.
I also found that by subtracting 3 * GetSystemMetrics(SM_CXSIZE) from the result to account for the buttons, it seems to be pretty accurate - but is 9 pixels smaller than the actual size available for the caption.
So, the value returned by SM_CXSIZE isn't quite right (it is 25, but the size of buttons is 21 pixels + a 2 pixel gap), but nothing else is right either.. even the caption height (SM_CYSMCAPTION) which returns 18, thus would give errors the "wrong" way.
Unfortunately several searches yielded nothing, but I did manage to find how to detect the font used:
I haven't worked out how to interpret the size (ncm.lfCaptionFont.lfHeight), but hopefully you can work it out from here.Code:Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(1 To 32) As Byte
End Type
Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type
Const SPI_GETNONCLIENTMETRICS = 41
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As NONCLIENTMETRICS, ByVal fuWinIni As Long) As Long
Private Sub Form_Load()
Dim ncm As NONCLIENTMETRICS
ncm.cbSize = Len(ncm)
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, ncm, 0)
MsgBox "Font Name: " & StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
End Sub
and once you know the length you can use the API PathCompactPath or PathCompactPathEx to acheive that compacting effect of the path that, for ex., Word uses.Quote:
Originally Posted by Martin
This seems to do it okay but I still need to include a couple of fudge factors. Does anyone see how to improve my calculations so I don't need them?
Code:ScaleMode = vbPixels
Dim TitleInfo As TITLEBARINFO
'Initialize structure
TitleInfo.cbSize = Len(TitleInfo)
'Retrieve information about the tilte bar of this window
GetTitleBarInfo Me.hWnd, TitleInfo
Dim intCtrlBoxWidth As Integer
Dim intIconWidth As Integer
Dim intTitleBarWidth As Integer
intCtrlBoxWidth = ((GetSystemMetrics(SM_CXSIZE)) * 3) + 12 ' I'm assuming I need to
' account for a few pixels between
' the control box buttons, hence the + 12
intIconWidth = GetSystemMetrics(SM_CXSMICON)
intTitleBarWidth = (TitleInfo.rcTitleBar.Right - TitleInfo.rcTitleBar.Left)
' Doesn't shorten soon enough without the + 60
Me.Caption = ShortenCaption(App.EXEName & " - " & strName, _
intTitleBarWidth - (intCtrlBoxWidth + intIconWidth + 60))
ScaleMode = vbTwips
I don't think you can get completely away from a fudge, as windows classic theme buttons display differently i.e in classic, the minimise and restore buttons do not have a space between them. It's also possible to show the "What's this Help" button together with the min/max/close buttons in classic, but not XP.
The nearest I can get is about 4 pixels, but depending on the font you might as well subtract 10 from what the following reports:
vb Code:
I'm not sure what you are demonstrating. What is PSP?
Okay I went back and looked at my ShortenCaption routine and realized that I had another fudge factor built into it so I replaced it with one of the APIs that Rob suggested. Using that API I need a 150 pixel fudge factor to get it to work properly. I can understand needing a small factor to prevent VB's normal shortening to kick in when the form is resized smaller, but why do I need so much? There must be something I'm overlooking or I'm doing wrong. Try the following in a new project.
Code:Option Explicit
Private Const MARTIN = "Picture Viewer - C:\Documents and Settings\Martin Liss\My Documents\My Pictures\2006-06 Hawai'i Cruise\IMG_1717.JPG"
Private Const CCHILDREN_TITLEBAR = 5
Private Const SM_CXSIZE = 30 'Width of a button in a window's caption or title bar, in pixels
Private Const SM_CXSMICON = 49 ' Width of a small icon, in pixels
Private Const SM_CXSMSIZE = 52 ' Width of small caption buttons, in pixels
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TITLEBARINFO
cbSize As Long
rcTitleBar As RECT
rgstate(CCHILDREN_TITLEBAR) As Long
End Type
Private Declare Function GetTitleBarInfo Lib "user32.dll" (ByVal hWnd As Long, ByRef pti As TITLEBARINFO) As Long
Private Declare Function PathCompactPath Lib "shlwapi.dll" Alias "PathCompactPathA" (ByVal hDC As Long, ByVal pszPath As String, ByVal dx As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Sub Form_Load()
ScaleMode = vbPixels
Width = 15000
Caption = MARTIN
End Sub
Private Sub Form_Resize()
Dim TitleInfo As TITLEBARINFO
Dim intCtrlBoxWidth As Integer
Dim intIconWidth As Integer
Dim intTitleBarWidth As Integer
Dim strPath As String
'Initialize structure
TitleInfo.cbSize = Len(TitleInfo)
'Retrieve information about the title bar of this window
GetTitleBarInfo Me.hWnd, TitleInfo
intCtrlBoxWidth = (GetSystemMetrics(SM_CXSIZE)) * 3
intIconWidth = GetSystemMetrics(SM_CXSMICON)
intTitleBarWidth = (TitleInfo.rcTitleBar.Right - TitleInfo.rcTitleBar.Left)
strPath = MARTIN
PathCompactPath Me.hDC, strPath, intTitleBarWidth - (intCtrlBoxWidth + intIconWidth) - 150
Me.Caption = strPath
End Sub
Sorry, my post was far from clear. PSP is Paintshop Pro. Where I have a comment like:Quote:
Originally Posted by MartinLiss
Debug = 269, PSP = 265, Difference = 4 pixels
Debug = 269
= the number of pixels the code indicates is availble for a captionPSP = 265
= the number of pixels a string of capital "X"s can occupy before the end of the caption shows an ellipses. Obtained by taking a screen capture and measuring the string of "X"s in Paintshop Pro.Difference = 4 pixels
= the code shows that up to 4 more pixels are available than the direct measurement from Paintshop Pro.
The code is meant to demonstrate that you can get the length of the writeable caption area, in pixels, just by using the API GetTitleBarInfo on its own.
Not that it matters now, because I've just tried your code and mine using PathCompactPath - with the same strange result. The API guide Parameters page says "The buffer must be at least MAX_PATH characters long" - usually defined as 256 - but "Dim strPath As String * 256" just puts an ellipses next to the minimise button, and stripping trailing spaces puts you back to square one.
So I've come up with this instead. It truncates the beginning of the caption, but with a suitable bit of tweaking could be made to remove characters from the middle. When I was testing it I noticed behaviour identical to that shown by PathCompactPath, leading me to think that PathCompactPath uses a default font rather than the one set by the user.
Hope it's useful (and understandable :D ). All it needs is a label - Label1 - on a form.
Code:Option Explicit
'Get the system's Titlebar font
Private Declare Function SystemParametersInfo Lib "user32.dll" Alias "SystemParametersInfoA" ( _
ByVal uiAction As Long, ByVal uiParam As Long, ByRef pvParam As Any, ByVal fWinIni As Long) As Long
Private Const LF_FACESIZE As Long = 32
Private Const SPI_GETNONCLIENTMETRICS As Long = 41
Private Type LogFont
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * LF_FACESIZE
End Type
Private Type NonClientMetrics
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LogFont
iSmCaptionWidth As Long
iSmCaptionHeight As Long
lfSmCaptionFont As LogFont
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LogFont
lfStatusFont As LogFont
lfMessageFont As LogFont
End Type
'Get Titlebar dimensions
Private Declare Function GetTitleBarInfo Lib "user32.dll" (ByVal hWnd As Long, ByRef pti As TITLEBARINFO) As Long
Private Const CCHILDREN_TITLEBAR = 5
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TITLEBARINFO
cbSize As Long
rcTitleBar As RECT
rgstate(CCHILDREN_TITLEBAR) As Long
End Type
Private Const MARTIN = "Picture Viewer - C:\Documents and Settings\Martin Liss\My Documents\My Pictures\2006-06 Hawai'i Cruise\IMG_1717.JPG"
Private Sub Form_Load()
Dim NCM As NonClientMetrics
Width = 15000 'Initial size...
'The caption will be automatically set by Form_Resize on loading
'See http://msdn.microsoft.com/en-us/library/ms533931(VS.85).aspx
NCM.cbSize = Len(NCM)
If (SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NCM.cbSize, NCM, 0&) <> 0) Then
'Set the label's font size...
Label1.FontSize = (NCM.lfCaptionFont.lfHeight * -1) - 3 'Proper formula in above link :)
'Set the label's font bold...
Select Case NCM.lfCaptionFont.lfWeight
Case 400
Label1.FontBold = False
Case 700
Label1.FontBold = True
Case Else
'God only knows.
End Select
'Set the label's font italic...
If NCM.lfCaptionFont.lfItalic = 0 Then
Label1.FontItalic = False
Else
Label1.FontItalic = True
End If
'Set the label's font underline...
If NCM.lfCaptionFont.lfUnderline = 0 Then
Label1.FontUnderline = False
Else
Label1.FontUnderline = True
End If
'Set the label's font StrikeOut...
If NCM.lfCaptionFont.lfStrikeOut = 0 Then
Label1.FontStrikethru = False
Else
Label1.FontStrikethru = True
End If
Label1.FontName = TrimNull(NCM.lfCaptionFont.lfFaceName)
End If
Label1.AutoSize = True
Label1.Top = -100
End Sub
Private Sub Form_Resize()
Dim TitleInfo As TITLEBARINFO
Dim intTitleBarWidth As Integer
Dim intTitleBarHeight As Integer
Dim intCapLen As Integer
TitleInfo.cbSize = Len(TitleInfo)
GetTitleBarInfo Me.hWnd, TitleInfo
intTitleBarWidth = TitleInfo.rcTitleBar.Right - TitleInfo.rcTitleBar.Left
intTitleBarHeight = TitleInfo.rcTitleBar.Bottom - TitleInfo.rcTitleBar.Top
'Set it for Min, Restore and Close buttons. 3 buttons = (intTitleBarHeight * 3)
intCapLen = intTitleBarWidth - (intTitleBarHeight * 3)
'Set the text string...
Label1.Caption = MARTIN
'Strip leading characters until it's the right length..
Do While Label1.Width > intCapLen
Label1.Caption = "... " & Right(Label1.Caption, Len(Label1.Caption) - 5)
Loop
'Display the final string...
Me.Caption = Label1.Caption
End Sub
Private Function TrimNull(strInput As String) As String
Dim lngNullPos As Long
lngNullPos = InStr(1, strInput, vbNullChar)
If (lngNullPos) Then
TrimNull = Left$(strInput, lngNullPos - 1)
Else
TrimNull = strInput
End If
End Function
Working with some code from vbAccelerator I have the solution. While there is a lot of code here I believe the key is that PathCompactPath uses the System Font (usually Tahoma).
Code: Part 1
Code:Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGFONTA
lfHeight As Long ' Specifies the height, in logical units, of the font's character cell or character. The character height value (also known as the em height) is the character cell height value minus the internal-leading value. (Fore more info on lfHeight, see the documentation for LOGFONT in the Win32 SDK)
lfWidth As Long ' Specifies the average width, in logical units, of characters in the font. If lfWidth is zero, the aspect ratio of the device is matched against the digitization aspect ratio of the available fonts to find the closest match, determined by the absolute value of the difference.
lfEscapement As Long ' Specifies the angle, in tenths of degrees, between the escapement vector and the x-axis of the device. The escapement vector is parallel to the base line of a row of text.
' Windows NT/2000 : When the graphics mode is set to GM_ADVANCED, you can specify the escapement angle of the string independently of the orientation angle of the string's characters. When the graphics mode is set to GM_COMPATIBLE, lfEscapement specifies both the escapement and orientation. You should set lfEscapement and lfOrientation to the same value.
' Windows 95 : The lfEscapement member specifies both the escapement and orientation. You should set lfEscapement and lfOrientation to the same value.
lfOrientation As Long ' Specifies the angle, in tenths of degrees, between each character's base line and the x-axis of the device.
lfWeight As Long ' Specifies the weight of the font in the range 0 through 1000. For example, 400 is normal and 700 is bold. If this value is zero, a default weight is used.
lfItalic As Byte ' Specifies an italic font if set to TRUE.
lfUnderline As Byte ' Specifies an underlined font if set to TRUE.
lfStrikeOut As Byte ' Specifies a strikeout font if set to TRUE.
lfCharSet As Byte ' Specifies the character set. (Fore more info on lfCharSet, see the documentation for LOGFONT in the Win32 SDK)
lfOutPrecision As Byte ' Specifies the output precision. The output precision defines how closely the output must match the requested font's height, width, character orientation, escapement, pitch, and font type.(Fore more info on lfOutPrecision, see the documentation for LOGFONT in the Win32 SDK)
lfClipPrecision As Byte ' Specifies the clipping precision. The clipping precision defines how to clip characters that are partially outside the clipping region.
lfQuality As Byte ' Specifies the output quality. The output quality defines how carefully the graphics device interface (GDI) must attempt to match the logical-font attributes to those of an actual physical font.
lfPitchAndFamily As Byte ' Specifies the pitch in the two low-order bits, and the family of the font in bits 4 through 7.
lfFaceName As String * 32
End Type
Private Type NONCLIENTMETRICSA
cbSize As Long ' Specifies the size of the structure, in bytes.
iBorderWidth As Long ' Specifies the thickness, in pixels, of the sizing border.
iScrollWidth As Long ' Specifies the width, in pixels, of a standard vertical scroll bar.
iScrollHeight As Long ' Specifies the height, in pixels, of a standard horizontal scroll bar.
iCaptionWidth As Long ' Specifies the width, in pixels, of caption buttons.
iCaptionHeight As Long ' Specifies the height, in pixels, of caption buttons.
lfCaptionFont As LOGFONTA ' Contains information about the caption font.
iSMCaptionWidth As Long ' Specifies the width, in pixels, of small caption buttons.
iSMCaptionHeight As Long ' Specifies the height, in pixels, of small captions.
lfSMCaptionFont As LOGFONTA ' Contains information about the small caption font.
iMenuWidth As Long ' Specifies the width, in pixels, of menu-bar buttons.
iMenuHeight As Long ' Specifies the height, in pixels, of a menu bar.
lfMenuFont As LOGFONTA ' Contains information about the font used in menu bars.
lfStatusFont As LOGFONTA ' Contains information about the font used in status bars and tooltips.
lfMessageFont As LOGFONTA ' Contains information about the font used in message boxes.
End Type
' Enumeration - GetSysFont/SetSysFont
Public Enum ClientFonts
cf_Caption = 0
cf_SmallCaption = 1
cf_Menu = 2
cf_Status = 3
cf_Message = 4
End Enum
' Constants - SystemParametersInfo
Private Const LOGPIXELSY = 90
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function PathCompactPath Lib "shlwapi.dll" Alias "PathCompactPathA" (ByVal hDc As Long, ByVal pszPath As String, ByVal dx As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.DLL" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function SystemParametersInfoA Lib "USER32.DLL" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SM_CMETRICS = 44
Private Const SM_CMOUSEBUTTONS = 43
Private Const SM_CXBORDER = 5
Private Const SM_CXCURSOR = 13
Private Const SM_CXDLGFRAME = 7
Private Const SM_CXDOUBLECLK = 36
Private Const SM_CXFIXEDFRAME = SM_CXDLGFRAME
Private Const SM_CXFRAME = 32
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CXHSCROLL = 21
Private Const SM_CXHTHUMB = 10
Private Const SM_CXICON = 11
Private Const SM_CXICONSPACING = 38
Private Const SM_CXMIN = 28
Private Const SM_CXMINTRACK = 34
Private Const SM_CXSCREEN = 0
Private Const SM_CXSMSIZE = 30
Private Const SM_CXSIZEFRAME = SM_CXFRAME
Private Const SM_CXVSCROLL = 2
Private Const SM_CYBORDER = 6
Private Const SM_CYCAPTION = 4
Private Const SM_CYCURSOR = 14
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYDOUBLECLK = 37
Private Const SM_CYFIXEDFRAME = SM_CYDLGFRAME
Private Const SM_CYFRAME = 33
Private Const SM_CYFULLSCREEN = 17
Private Const SM_CYHSCROLL = 3
Private Const SM_CYICON = 12
Private Const SM_CYICONSPACING = 39
Private Const SM_CYKANJIWINDOW = 18
Private Const SM_CYMENU = 15
Private Const SM_CYMIN = 29
Private Const SM_CYMINTRACK = 35
Private Const SM_CYSCREEN = 1
Private Const SM_CYSMSIZE = 31
Private Const SM_CYSIZEFRAME = SM_CYFRAME
Private Const SM_CYVSCROLL = 20
Private Const SM_CYVTHUMB = 9
Private Const SM_DBCSENABLED = 42
Private Const SM_DEBUG = 22
Private Const SM_MENUDROPALIGNMENT = 40
Private Const SM_MOUSEPRESENT = 19
Private Const SM_PENWINDOWS = 41
Private Const SM_RESERVED1 = 24
Private Const SM_RESERVED2 = 25
Private Const SM_RESERVED3 = 26
Private Const SM_RESERVED4 = 27
Private Const SM_SWAPBUTTON = 23
Private Const SM_CYSMCAPTION = 51
Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private Const MARTIN = "Picture Viewer - C:\Documents and Settings\Martin Liss\My Documents\My Pictures\2006-06 Hawai'i Cruise\IMG_1717.JPG"
Part 2:
Code:Private Sub Form_Load()
Dim sFnt As New StdFont
ScaleMode = vbPixels
Width = 15000
Caption = MARTIN
' Get the current system font
If GetSysFontA(sFnt, Me.hDc, cf_Caption) = True Then
With Me.Font
.Name = sFnt.Name
.Bold = sFnt.Bold
.Italic = sFnt.Italic
.Size = sFnt.Size
End With
End If
End Sub
Private Sub Form_Resize()
Dim strPath As String
strPath = MARTIN
PathCompactPath Me.hDc, strPath, TitleBarCaptionWidth(hWnd)
Me.Caption = strPath
End Sub
Function TitleBarCaptionWidth(ByVal hWnd As Long) As Long
Dim DestWidth As Long
Dim GradhWnd As Long
Dim wndRect As RECT
Dim rct As RECT
Dim XBorder As Long
Dim lS As Long
Dim lBtnWidth As Long
Dim PixelStep As Long
Dim DestHeight As Long
GetWindowRect Me.hWnd, wndRect
With wndRect
DestWidth = .Right - .Left
End With
DestHeight = GetSystemMetrics(SM_CYCAPTION)
XBorder = GetSystemMetrics(SM_CXFRAME)
'The width of the area we need to paint:
DestWidth = DestWidth - (XBorder * 2) + 6
lS = GetWindowLong(Me.hWnd, GWL_STYLE)
If ((lS And WS_MINIMIZEBOX) = WS_MINIMIZEBOX) Or ((lS And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX) Then
lBtnWidth = lBtnWidth + (GetSystemMetrics(SM_CXSMSIZE)) * 2
End If
If ((lS And WS_SYSMENU) = WS_SYSMENU) Then
lBtnWidth = lBtnWidth + (GetSystemMetrics(SM_CXSMSIZE))
End If
If (lBtnWidth <> 0) Then lBtnWidth = lBtnWidth + 1
DestWidth = DestWidth - lBtnWidth
With rct
.Top = XBorder
.Left = XBorder
.Right = XBorder + DestWidth - 4
.Bottom = XBorder + DestHeight - 1
'Move the caption text's start point over
'to make room for the icon
.Left = XBorder + GetSystemMetrics(SM_CXSMSIZE) + 2
.Left = .Left + 2
.Right = .Right - 10
'Draw the caption text
'DrawText DrawDC, fText, Len(fText) - 1, rct, DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_VCENTER
Debug.Print "Left,Right", rct.Left, rct.Right
TitleBarCaptionWidth = rct.Right - rct.Left
End With
End Function
Public Function GetSysFontA(ByRef Return_Font As StdFont, ByVal hDc As Long, ByVal FontToGet As ClientFonts) As Boolean
Dim NCInfo As NONCLIENTMETRICSA
Dim FontInfo As LOGFONTA
On Error GoTo ErrorTrap
' Clear the return variable
Set Return_Font = Nothing
' Set the buffer size of the parameter to be passed
NCInfo.cbSize = Len(NCInfo)
' Get the font information
If SystemParametersInfoA(SPI_GETNONCLIENTMETRICS, 0, NCInfo, 0) <> 0 Then
' Check the result
If NCInfo.iCaptionHeight = 0 Then
FontInfo.lfHeight = 0
Else
' Store the previous caption/menu height. If you change the font's size UP, the
' caption/menu height will change. If you change the font DOWN, the caption/menu
' height does not automatically change smaller.
'PrevCaptionHeight = NCInfo.iCaptionHeight
'PrevMenuHeight = NCInfo.iMenuHeight
' Get the right font to return
Select Case FontToGet
Case cf_Caption
FontInfo = NCInfo.lfCaptionFont
Case cf_Menu
FontInfo = NCInfo.lfMenuFont
Case cf_Message
FontInfo = NCInfo.lfMessageFont
Case cf_SmallCaption
FontInfo = NCInfo.lfSMCaptionFont
Case cf_Status
FontInfo = NCInfo.lfStatusFont
End Select
' Set the return font according to the API results
Set Return_Font = New StdFont
With Return_Font
.Charset = FontInfo.lfCharSet
.Weight = FontInfo.lfWeight
.Name = FontInfo.lfFaceName
.Strikethrough = FontInfo.lfStrikeOut
.Underline = FontInfo.lfUnderline
.Italic = FontInfo.lfItalic
.Bold = (FontInfo.lfWeight = 700)
.Size = -(FontInfo.lfHeight * (72 / GetDeviceCaps(hDc, LOGPIXELSY)))
End With
GetSysFontA = True
Exit Function
End If
End If
ErrorTrap:
If Err.Number = 0 Then ' No Error
Resume Next
ElseIf Err.Number = 20 Then ' Resume Without Error
Resume Next
Else ' Unknown Error
MsgBox Err.Source & " encountered the following error:" & Chr(13) & Chr(13) & "Error Number = " & CStr(Err.Number) & Chr(13) & "Error Description = " & Err.Description, vbOKOnly + vbExclamation, " Error - " & Err.Description
Err.Clear
Exit Function
End If
End Function