[RESOLVED] TextWidth of form caption

[MartinLiss]

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?

[si_the_geek]

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.

[MartinLiss]

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 is

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).

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

It works for me if I do the following

Me.Caption = ShortenCaption("The text I want to put in the caption", ScaleWidth - 3800)

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 code

Debug.Print GetSystemMetrics(SM_CXSIZE) * Screen.TwipsPerPixelX
Debug.Print GetSystemMetrics(SM_CXSMICON) * Screen.TwipsPerPixelX
Debug.Print GetSystemMetrics(SM_CXSMSIZE) * Screen.TwipsPerPixelX

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.

[schoolbusdriver]

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.

[si_the_geek]

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:

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

I haven't worked out how to interpret the size (ncm.lfCaptionFont.lfHeight), but hopefully you can work it out from here.

[RobDog888]

Yup I know that Windows automatically truncates captions but what I'd like to do is

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.

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.

[MartinLiss]

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?

    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

[schoolbusdriver]

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:

Option Explicit
 
'Form level code
 
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 Sub Form_Load()
   Dim TitleInfo           As TITLEBARINFO
   Dim lngTitleBarHeight   As Long
   Dim lngTitleBarWidth    As Long
   Dim lngButtonsWidth     As Long
   Dim Index               As Integer
   
   Me.ScaleMode = vbPixels
   Me.Height = 3540
   Me.Width = 4740
 
'Set the StartUpPosition to 2: CenterScreen.
 
'Change the buttons properties to suit.
   
'Change your PC's theme to whichever before using the figures this provides.
 
   TitleInfo.cbSize = Len(TitleInfo)
   GetTitleBarInfo Me.hwnd, TitleInfo
   lngTitleBarHeight = TitleInfo.rcTitleBar.Bottom - TitleInfo.rcTitleBar.Top
   lngTitleBarWidth = TitleInfo.rcTitleBar.Right - TitleInfo.rcTitleBar.Left
   Debug.Print "Calculated Writeable length in pixels:"
   For Index = 1 To 6
      Select Case Index
'Windows classic theme.
      Case 1 'X only
         'Add 2 pixel buffer at left of leftmost button.
         lngButtonsWidth = lngTitleBarHeight + 2 'Debug = 269, PSP = 265, Difference = 4 pixels
      Case 2 'X + Min + Max/Restore
         'Min & Resize buttons are not seperated so no is buffer needed.
         lngButtonsWidth = lngTitleBarHeight * 3 'Debug = 233, PSP = 230, Difference = 3 pixels
      Case 3 'X + Min + Max/Restore + Help
         'Add 2 pixel buffer at left of leftmost button.
         lngButtonsWidth = (lngTitleBarHeight * 4) + 2 'Debug = 212, PSP = 209, Difference = 3 pixels
'XP theme.
      Case 4 'X only
         lngButtonsWidth = lngTitleBarHeight 'Debug = 257, PSP = 259, Difference = 2 pixels
      Case 5 'X + Min + Max/Restore
         lngButtonsWidth = lngTitleBarHeight * 3 'Debug = 205, PSP = 207, Difference = 2 pixels
      Case 6 'X + Help
         lngButtonsWidth = lngTitleBarHeight * 2 'Debug = 231, PSP = 234, Difference = 3 pixels
      End Select
      Debug.Print "Case " & Index & "  " & lngTitleBarWidth - lngButtonsWidth
   Next
   ScaleMode = vbTwips
End Sub

[MartinLiss]

I'm not sure what you are demonstrating. What is PSP?

[MartinLiss]

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.

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

[schoolbusdriver]

I'm not sure what you are demonstrating. What is PSP?

Sorry, my post was far from clear. PSP is Paintshop Pro. Where I have a comment like:

Debug = 269, PSP = 265, Difference = 4 pixels

Debug = 269
= the number of pixels the code indicates is availble for a caption

PSP = 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 ). All it needs is a label - Label1 - on a form.

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

[MartinLiss]

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

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"

[MartinLiss]

Part 2:

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