Forms Captions (Or Image)

Hey,

Have a question regarding a forms caption... typicly a forms caption is right aligned with an image in the top left corner.

I need to know if it is possible to have some text on the left and a fixed piece of text (8 chars) right alligned near the controlbox.

Is this possible? I cant see an obvious way at the moment! if we cant do 8 character would it be possible to have an image just before the control box?

Thanks

I can see it being done with a little help from the TextWidth() method...

Yea any ideas for an alg? I've put a few together but getting a bit of a mixed result.

No clue, but I'd assume it would consist of finding out the titlebar's font(and therefore font width, size, etc), converting it to pixels, finding the window's width in pixels, subtracting the border size, icon size and placement, and control box size and placement, then divide what's leftover by the width of a " " character in the current font familiy and add that many characters to the titlebar(minus the width of the text you wish to display, of course).

Something like that. I'm sure it's possible, somehow.

check it out, it's basically what Brendan has already described

VB Code:

Option Explicit
 
Private Const LF_FACESIZE = 32
 
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 LF_FACESIZE) 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
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
    ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, ByVal nIndex As Long) As Long
 
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const LOGPIXELSY = 90
 
Private ncm As NONCLIENTMETRICS
 
Private Sub Form_Load()
    Dim sFont As String
    Dim lPos As Long
    
    ncm.cbSize = Len(ncm)
    If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0&) Then
        sFont = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
        lPos = InStr(sFont, vbNullChar)
        If lPos Then sFont = Left$(sFont, lPos - 1)
        Me.FontName = sFont
        Me.FontSize = (-ncm.lfCaptionFont.lfHeight * 72) / GetDeviceCaps(Me.hdc, LOGPIXELSY)
    End If
End Sub
 
Private Sub Form_Resize()
    Const CAPTION As String = "Test Caption", EXTRATEXT As String = " more text"
    Dim lWidth As Long, sngCharWidth As Single, sngTextWidth As Single, lNum As Long
    
    ' calculate the area we have to play with (15 is just padding)
    lWidth = (Me.Width \ Screen.TwipsPerPixelX) - 16 - ncm.iCaptionWidth * 3 - ncm.iBorderWidth * 2 - 15
    
    sngCharWidth = Me.TextWidth(" ") / Screen.TwipsPerPixelX
    sngTextWidth = Me.TextWidth(CAPTION & EXTRATEXT) / Screen.TwipsPerPixelX
    
    lNum = (lWidth - sngTextWidth) \ sngCharWidth
    If lNum < 0 Then lNum = 0
    
    Me.CAPTION = CAPTION & Space$(lNum) & EXTRATEXT
End Sub

it works surprisingly well, I'm pleased to say :)

(getting the font name was modified from here)

Yup, that works. Only one problem: try maximizing your window when your screen res is at least 1280 x 1024 ;D

Right-adjusted caption pulls a Houdini.

Quote:

---

Originally Posted by BrendanDavis

Yup, that works. Only one problem: try maximizing your window when your screen res is at least 1280 x 1024 ;D

Right-adjusted caption pulls a Houdini.

---

ah yes, didn't try that - it's cos the caption will only display 255 (or 256 or whatever) characters.

the alternative I guess is to subclass the form, look for the WM_NCPAINT message and then draw the text on to title bar (which i couldn't be bothered to do)

For that purpose I would just build my own titlebar - I think I have sample posted awhile back so if anyone interested then search.

ok, here's a subclassing and drawing version (module code only - just call the obvious subs).

It hasn't really come out how I like, for some reason it won't draw the text transparent on the titlebar (it would be ok if it weren't for that :(). Anyhoo, I don't know much about graphics so this is pretty much the best I can do - if anyone can improve it, then please do!

Code:

---

       

VB Code:

       

Option Explicit

 
Private Const LF_FACESIZE = 32

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

 
Private Type RECT

    Left As Long

    Top As Long

    Right As Long

    Bottom As Long

End Type

 
' SubClassing

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _

    ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

    

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _

    ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _

    ByVal lParam As Long) As Long

 
Private Const GWL_WNDPROC = (-4)

 
Private Const WM_NCACTIVATE = &H86

Private Const WM_NCPAINT = &H85

 
Private lPrevProc As Long

 
' Positioning & Drawing

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _

    ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

 
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

 
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

 
Private Const SPI_GETNONCLIENTMETRICS = 41

Private Const LOGPIXELSY = 90

Private Const COLOR_ACTIVECAPTION = 2

Private Const COLOR_CAPTIONTEXT = 9

 
Public sExtraText As String

Private oForm As Form

Private ncm As NONCLIENTMETRICS

 
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim wDC As Long, r As RECT, lFont As Long, lOldFont As Long

    Dim lWidth As Long, sngCharWidth As Single, sngTextWidth As Single, lNum As Long

    

    WndProc = CallWindowProc(lPrevProc, hwnd, Msg, wParam, lParam)

    Select Case Msg

        Case WM_NCPAINT, WM_NCACTIVATE

            ' calculate the area we have to play with (15 is just padding)

            lWidth = (oForm.Width \ Screen.TwipsPerPixelX) - 16 - ncm.iCaptionWidth * 3 - ncm.iBorderWidth * 2 - 15

    

            sngCharWidth = oForm.TextWidth(" ") / Screen.TwipsPerPixelX

            sngTextWidth = oForm.TextWidth(oForm.Caption & sExtraText) / Screen.TwipsPerPixelX

            

            If lWidth - sngTextWidth > 0 Then

                wDC = GetWindowDC(hwnd)

                

                ' this should make the back transparent (but doesn't)

                SetBkColor wDC, 1& 'GetSysColor(COLOR_ACTIVECAPTION)

                SetTextColor wDC, GetSysColor(COLOR_CAPTIONTEXT)

                

                lFont = CreateFontIndirect(ncm.lfCaptionFont)

                lOldFont = SelectObject(wDC, lFont)

                

                With r

                    .Top = ncm.iBorderWidth * 6

                    .Left = lWidth + 16 - (oForm.TextWidth(sExtraText) / Screen.TwipsPerPixelX)

                    .Bottom = oForm.TextHeight(sExtraText) ' / Screen.TwipsPerPixelY

                    .Right = oForm.TextWidth(sExtraText) ' / Screen.TwipsPerPixelX

                End With

                

                DrawText wDC, sExtraText, Len(sExtraText), r, 0&

                

                ' clear up

                SelectObject wDC, lOldFont

                DeleteObject lFont

                ReleaseDC hwnd, wDC

            End If

    End Select

End Function

 
Public Sub AddExtraTextSubClass(ByRef oFrm As Form)

    Dim sFont As String, lPos As Long

    

    Set oForm = oFrm

    lPrevProc = SetWindowLong(oForm.hwnd, GWL_WNDPROC, AddressOf WndProc)

    

    ncm.cbSize = Len(ncm)

    SystemParametersInfo SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0&

    sFont = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)

    lPos = InStr(sFont, vbNullChar)

    If lPos Then sFont = Left$(sFont, lPos - 1)

    oFrm.FontName = sFont

    oFrm.FontSize = (-ncm.lfCaptionFont.lfHeight * 72) / GetDeviceCaps(oForm.hdc, LOGPIXELSY)

End Sub

 
Public Sub UnSubClass(ByRef oFrm As Form)

    SetWindowLong oFrm.hwnd, GWL_WNDPROC, lPrevProc

    Set oForm = Nothing

End Sub

---

@bush:

how did you manage to get VBCODE within CODE tags? :)

Quote:

---

Originally Posted by RhinoBull

@bush:

how did you manage to get VBCODE within CODE tags? :)

---

do:

[CODE]
[VBCODE]
' Your
' VB
' Code
[/VBCODE]






(the number of CRs you put here determines how big the CODE box is)
[/CODE]

Isnt your caption text left aligned by default? :confused:


@RB just type [Highlight=VB] tags within [code] tags.

Code:

---

@RhinoBull

       

VB Code:

       

By nesting the tags and putting blank lines between the [open]a[/open]/VBCode[close]a[/close] and [open]a[/open]/Code[close]a[/close] tags:

 
[open]a[/open]Code[close]a[/close][open]a[/open]VBCode[close]a[/close]

code here

[open]a[/open]/VBCode[close]a[/close]

lots of blank lines to open the code box up

[open]a[/open]/Code[close]a[/close]

 
 
Option Explicit

 
Private Const LF_FACESIZE = 32

 
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

 
etc.

---

I remember doing some right aligning of menus as it was a built in feature. Perhaps something similar for the titlebar?

@anyone who relpied to VBCODE/CODE:

It was intended as a joke - there is no point in using both - it's one or the other but better VBCODE... ;)

Quote:

---

Originally Posted by RhinoBull

@anyone who relpied to VBCODE/CODE:

I was intended as a joke - there is no point in using both - it's one or the other but better VBCODE... ;)

---

there is a good reason for using both - my post would have been massive if i had just put VBCODE tags on, and if I'd just used CODE tags it wouldn't have had the syntax highlighting and have been difficult to read.


regarding Pino's original question - I just assumed he wanted both R and L justified text in the title bar.

So then it would be centered text?

Quote:

---

Originally Posted by bushmobile

there is a good reason for using both - my post would have been massive if i had just put VBCODE tags on, and if I'd just used CODE tags it wouldn't have had the syntax highlighting and have been difficult to read..

---

It is even more difficult to read with scrollbars though. I prefer to see the entire thing.

Quote:

---

Originally Posted by RhinoBull

It is even more difficult to read with scrollbars though. I prefer to see the entire thing.

---

If he wouldn't use [CODE] you would get even larger scrollbars in your browser which are harder to manage i guess :)

Bush's code reposted for myself for better readability

VB Code:

Option Explicit
 
Private Const LF_FACESIZE = 32
 
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 LF_FACESIZE) 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
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
' SubClassing
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
 
Private Const GWL_WNDPROC = (-4)
 
Private Const WM_NCACTIVATE = &H86
Private Const WM_NCPAINT = &H85
 
Private lPrevProc As Long
 
' Positioning & Drawing
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
    ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
 
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
 
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const LOGPIXELSY = 90
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_CAPTIONTEXT = 9
 
Public sExtraText As String
Private oForm As Form
Private ncm As NONCLIENTMETRICS
 
Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim wDC As Long, r As RECT, lFont As Long, lOldFont As Long
    Dim lWidth As Long, sngCharWidth As Single, sngTextWidth As Single, lNum As Long
    
    WndProc = CallWindowProc(lPrevProc, hwnd, Msg, wParam, lParam)
    Select Case Msg
        Case WM_NCPAINT, WM_NCACTIVATE
            ' calculate the area we have to play with (15 is just padding)
            lWidth = (oForm.Width \ Screen.TwipsPerPixelX) - 16 - ncm.iCaptionWidth * 3 - ncm.iBorderWidth * 2 - 15
    
            sngCharWidth = oForm.TextWidth(" ") / Screen.TwipsPerPixelX
            sngTextWidth = oForm.TextWidth(oForm.Caption & sExtraText) / Screen.TwipsPerPixelX
            
            If lWidth - sngTextWidth > 0 Then
                wDC = GetWindowDC(hwnd)
                
                ' this should make the back transparent (but doesn't)
                SetBkColor wDC, 1& 'GetSysColor(COLOR_ACTIVECAPTION)
                SetTextColor wDC, GetSysColor(COLOR_CAPTIONTEXT)
                
                lFont = CreateFontIndirect(ncm.lfCaptionFont)
                lOldFont = SelectObject(wDC, lFont)
                
                With r
                    .Top = ncm.iBorderWidth * 6
                    .Left = lWidth + 16 - (oForm.TextWidth(sExtraText) / Screen.TwipsPerPixelX)
                    .Bottom = oForm.TextHeight(sExtraText) ' / Screen.TwipsPerPixelY
                    .Right = oForm.TextWidth(sExtraText) ' / Screen.TwipsPerPixelX
                End With
                
                DrawText wDC, sExtraText, Len(sExtraText), r, 0&
                
                ' clear up
                SelectObject wDC, lOldFont
                DeleteObject lFont
                ReleaseDC hwnd, wDC
            End If
    End Select
End Function
 
Public Sub AddExtraTextSubClass(ByRef oFrm As Form)
    Dim sFont As String, lPos As Long
    
    Set oForm = oFrm
    lPrevProc = SetWindowLong(oForm.hwnd, GWL_WNDPROC, AddressOf WndProc)
    
    ncm.cbSize = Len(ncm)
    SystemParametersInfo SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0&
    sFont = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
    lPos = InStr(sFont, vbNullChar)
    If lPos Then sFont = Left$(sFont, lPos - 1)
    oFrm.FontName = sFont
    oFrm.FontSize = (-ncm.lfCaptionFont.lfHeight * 72) / GetDeviceCaps(oForm.hdc, LOGPIXELSY)
End Sub
 
Public Sub UnSubClass(ByRef oFrm As Form)
    SetWindowLong oFrm.hwnd, GWL_WNDPROC, lPrevProc
    Set oForm = Nothing
End Sub