PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197

PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197

PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197

PHP User Warning: fetch_template() calls should be replaced by the vB_Template class. Template name: bbcode_highlight in ..../includes/functions.php on line 4197
Forms Captions (Or Image)-VBForums
Results 1 to 20 of 20

Thread: Forms Captions (Or Image)

  1. #1

    Thread Starter
    Super Moderator
    Join Date
    Dec 2003
    Posts
    4,787

    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
    Last edited by Pino; Jan 11th, 2007 at 09:22 AM.

  2. #2
    PowerPoster gavio's Avatar
    Join Date
    Feb 2006
    Location
    GMT+1
    Posts
    4,462

    Re: Forms Captions (Or Image)

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

  3. #3

    Thread Starter
    Super Moderator
    Join Date
    Dec 2003
    Posts
    4,787

    Re: Forms Captions (Or Image)

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

  4. #4
    Hyperactive Member BrendanDavis's Avatar
    Join Date
    Oct 2006
    Location
    Florida
    Posts
    492

    Re: Forms Captions (Or Image)

    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.

  5. #5
    Oi, fat-rag! bushmobile's Avatar
    Join Date
    Mar 2004
    Location
    on the poop deck
    Posts
    5,592

    Re: Forms Captions (Or Image)

    check it out, it's basically what Brendan has already described
    VB Code:
    1. Option Explicit
    2.  
    3. Private Const LF_FACESIZE = 32
    4.  
    5. Private Type LOGFONT
    6.     lfHeight As Long
    7.     lfWidth As Long
    8.     lfEscapement As Long
    9.     lfOrientation As Long
    10.     lfWeight As Long
    11.     lfItalic As Byte
    12.     lfUnderline As Byte
    13.     lfStrikeOut As Byte
    14.     lfCharSet As Byte
    15.     lfOutPrecision As Byte
    16.     lfClipPrecision As Byte
    17.     lfQuality As Byte
    18.     lfPitchAndFamily As Byte
    19.     lfFaceName(1 To LF_FACESIZE) As Byte
    20. End Type
    21.  
    22. Private Type NONCLIENTMETRICS
    23.     cbSize As Long
    24.     iBorderWidth As Long
    25.     iScrollWidth As Long
    26.     iScrollHeight As Long
    27.     iCaptionWidth As Long
    28.     iCaptionHeight As Long
    29.     lfCaptionFont As LOGFONT
    30.     iSMCaptionWidth As Long
    31.     iSMCaptionHeight As Long
    32.     lfSMCaptionFont As LOGFONT
    33.     iMenuWidth As Long
    34.     iMenuHeight As Long
    35.     lfMenuFont As LOGFONT
    36.     lfStatusFont As LOGFONT
    37.     lfMessageFont As LOGFONT
    38. End Type
    39.  
    40. Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
    41.     ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    42.  
    43. Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    44.     ByVal hdc As Long, ByVal nIndex As Long) As Long
    45.  
    46. Private Const SPI_GETNONCLIENTMETRICS = 41
    47. Private Const LOGPIXELSY = 90
    48.  
    49. Private ncm As NONCLIENTMETRICS
    50.  
    51. Private Sub Form_Load()
    52.     Dim sFont As String
    53.     Dim lPos As Long
    54.    
    55.     ncm.cbSize = Len(ncm)
    56.     If SystemParametersInfo(SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0&) Then
    57.         sFont = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
    58.         lPos = InStr(sFont, vbNullChar)
    59.         If lPos Then sFont = Left$(sFont, lPos - 1)
    60.         Me.FontName = sFont
    61.         Me.FontSize = (-ncm.lfCaptionFont.lfHeight * 72) / GetDeviceCaps(Me.hdc, LOGPIXELSY)
    62.     End If
    63. End Sub
    64.  
    65. Private Sub Form_Resize()
    66.     Const CAPTION As String = "Test Caption", EXTRATEXT As String = " more text"
    67.     Dim lWidth As Long, sngCharWidth As Single, sngTextWidth As Single, lNum As Long
    68.    
    69.     ' calculate the area we have to play with (15 is just padding)
    70.     lWidth = (Me.Width \ Screen.TwipsPerPixelX) - 16 - ncm.iCaptionWidth * 3 - ncm.iBorderWidth * 2 - 15
    71.    
    72.     sngCharWidth = Me.TextWidth(" ") / Screen.TwipsPerPixelX
    73.     sngTextWidth = Me.TextWidth(CAPTION & EXTRATEXT) / Screen.TwipsPerPixelX
    74.    
    75.     lNum = (lWidth - sngTextWidth) \ sngCharWidth
    76.     If lNum < 0 Then lNum = 0
    77.    
    78.     Me.CAPTION = CAPTION & Space$(lNum) & EXTRATEXT
    79. End Sub
    it works surprisingly well, I'm pleased to say

    (getting the font name was modified from here)

  6. #6
    Hyperactive Member BrendanDavis's Avatar
    Join Date
    Oct 2006
    Location
    Florida
    Posts
    492

    Re: Forms Captions (Or Image)

    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.

  7. #7
    Oi, fat-rag! bushmobile's Avatar
    Join Date
    Mar 2004
    Location
    on the poop deck
    Posts
    5,592

    Re: Forms Captions (Or Image)

    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)

  8. #8

  9. #9
    Oi, fat-rag! bushmobile's Avatar
    Join Date
    Mar 2004
    Location
    on the poop deck
    Posts
    5,592

    Re: Forms Captions (Or Image)

    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:
    1. Option Explicit
    2.  
    3. Private Const LF_FACESIZE = 32
    4.  
    5. Private Type LOGFONT
    6.     lfHeight As Long
    7.     lfWidth As Long
    8.     lfEscapement As Long
    9.     lfOrientation As Long
    10.     lfWeight As Long
    11.     lfItalic As Byte
    12.     lfUnderline As Byte
    13.     lfStrikeOut As Byte
    14.     lfCharSet As Byte
    15.     lfOutPrecision As Byte
    16.     lfClipPrecision As Byte
    17.     lfQuality As Byte
    18.     lfPitchAndFamily As Byte
    19.     lfFaceName(1 To LF_FACESIZE) As Byte
    20. End Type
    21.  
    22. Private Type NONCLIENTMETRICS
    23.     cbSize As Long
    24.     iBorderWidth As Long
    25.     iScrollWidth As Long
    26.     iScrollHeight As Long
    27.     iCaptionWidth As Long
    28.     iCaptionHeight As Long
    29.     lfCaptionFont As LOGFONT
    30.     iSMCaptionWidth As Long
    31.     iSMCaptionHeight As Long
    32.     lfSMCaptionFont As LOGFONT
    33.     iMenuWidth As Long
    34.     iMenuHeight As Long
    35.     lfMenuFont As LOGFONT
    36.     lfStatusFont As LOGFONT
    37.     lfMessageFont As LOGFONT
    38. End Type
    39.  
    40. Private Type RECT
    41.     Left As Long
    42.     Top As Long
    43.     Right As Long
    44.     Bottom As Long
    45. End Type
    46.  
    47. ' SubClassing
    48. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    49.     ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    50.    
    51. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    52.     ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
    53.     ByVal lParam As Long) As Long
    54.  
    55. Private Const GWL_WNDPROC = (-4)
    56.  
    57. Private Const WM_NCACTIVATE = &H86
    58. Private Const WM_NCPAINT = &H85
    59.  
    60. Private lPrevProc As Long
    61.  
    62. ' Positioning & Drawing
    63. Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
    64.     ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    65.  
    66. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    67.  
    68. Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    69. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    70. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    71. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    72. Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    73. 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
    74. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    75. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    76. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    77.  
    78. Private Const SPI_GETNONCLIENTMETRICS = 41
    79. Private Const LOGPIXELSY = 90
    80. Private Const COLOR_ACTIVECAPTION = 2
    81. Private Const COLOR_CAPTIONTEXT = 9
    82.  
    83. Public sExtraText As String
    84. Private oForm As Form
    85. Private ncm As NONCLIENTMETRICS
    86.  
    87. Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    88.     Dim wDC As Long, r As RECT, lFont As Long, lOldFont As Long
    89.     Dim lWidth As Long, sngCharWidth As Single, sngTextWidth As Single, lNum As Long
    90.    
    91.     WndProc = CallWindowProc(lPrevProc, hwnd, Msg, wParam, lParam)
    92.     Select Case Msg
    93.         Case WM_NCPAINT, WM_NCACTIVATE
    94.             ' calculate the area we have to play with (15 is just padding)
    95.             lWidth = (oForm.Width \ Screen.TwipsPerPixelX) - 16 - ncm.iCaptionWidth * 3 - ncm.iBorderWidth * 2 - 15
    96.    
    97.             sngCharWidth = oForm.TextWidth(" ") / Screen.TwipsPerPixelX
    98.             sngTextWidth = oForm.TextWidth(oForm.Caption & sExtraText) / Screen.TwipsPerPixelX
    99.            
    100.             If lWidth - sngTextWidth > 0 Then
    101.                 wDC = GetWindowDC(hwnd)
    102.                
    103.                 ' this should make the back transparent (but doesn't)
    104.                 SetBkColor wDC, 1& 'GetSysColor(COLOR_ACTIVECAPTION)
    105.                 SetTextColor wDC, GetSysColor(COLOR_CAPTIONTEXT)
    106.                
    107.                 lFont = CreateFontIndirect(ncm.lfCaptionFont)
    108.                 lOldFont = SelectObject(wDC, lFont)
    109.                
    110.                 With r
    111.                     .Top = ncm.iBorderWidth * 6
    112.                     .Left = lWidth + 16 - (oForm.TextWidth(sExtraText) / Screen.TwipsPerPixelX)
    113.                     .Bottom = oForm.TextHeight(sExtraText) ' / Screen.TwipsPerPixelY
    114.                     .Right = oForm.TextWidth(sExtraText) ' / Screen.TwipsPerPixelX
    115.                 End With
    116.                
    117.                 DrawText wDC, sExtraText, Len(sExtraText), r, 0&
    118.                
    119.                 ' clear up
    120.                 SelectObject wDC, lOldFont
    121.                 DeleteObject lFont
    122.                 ReleaseDC hwnd, wDC
    123.             End If
    124.     End Select
    125. End Function
    126.  
    127. Public Sub AddExtraTextSubClass(ByRef oFrm As Form)
    128.     Dim sFont As String, lPos As Long
    129.    
    130.     Set oForm = oFrm
    131.     lPrevProc = SetWindowLong(oForm.hwnd, GWL_WNDPROC, AddressOf WndProc)
    132.    
    133.     ncm.cbSize = Len(ncm)
    134.     SystemParametersInfo SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0&
    135.     sFont = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
    136.     lPos = InStr(sFont, vbNullChar)
    137.     If lPos Then sFont = Left$(sFont, lPos - 1)
    138.     oFrm.FontName = sFont
    139.     oFrm.FontSize = (-ncm.lfCaptionFont.lfHeight * 72) / GetDeviceCaps(oForm.hdc, LOGPIXELSY)
    140. End Sub
    141.  
    142. Public Sub UnSubClass(ByRef oFrm As Form)
    143.     SetWindowLong oFrm.hwnd, GWL_WNDPROC, lPrevProc
    144.     Set oForm = Nothing
    145. End Sub

  10. #10

  11. #11
    Oi, fat-rag! bushmobile's Avatar
    Join Date
    Mar 2004
    Location
    on the poop deck
    Posts
    5,592

    Re: Forms Captions (Or Image)

    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]

  12. #12
    Super Moderator RobDog888's Avatar
    Join Date
    Apr 2001
    Location
    LA, Calif. Raiders #1 AKA:Gangsta Yoda™
    Posts
    60,622

    Re: Forms Captions (Or Image)

    Isnt your caption text left aligned by default?


    @RB just type [Highlight=VB] tags within [code] tags.
    VB/Office Guru™ (AKA: Gangsta Yoda®)
    I dont answer coding questions via PM. Please post a thread in the appropriate forum.

    Microsoft MVP 2006-2011
    Office Development FAQ (C#, VB.NET, VB 6, VBA)
    Senior Jedi Software Engineer MCP (VB 6 & .NET), BSEE, CET
    If a post has helped you then Please Rate it!
    Reps & Rating PostsVS.NET on Vista Multiple .NET Framework Versions Office Primary Interop AssembliesVB/Office Guru™ Word SpellChecker™.NETVB/Office Guru™ Word SpellChecker™ VB6VB.NET Attributes Ex.Outlook Global Address ListAPI Viewer utility.NET API Viewer Utility
    System: Intel i7 6850K, Corsair H100i v2 water cooler, Geforce GTX1060, Samsung M.2 500 GB & SATA 500 GB, 32 GBs DDR4 3300 Quad Channel RAM, 2 Viewsonic 24" LCDs, Windows 10, Office 2010, VS 2010

  13. #13
    PowerPoster
    Join Date
    Feb 2006
    Location
    East of NYC, USA
    Posts
    5,692

    Re: Forms Captions (Or Image)

    Code:
    @RhinoBull
    VB Code:
    1. 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:
    2.  
    3. [open]a[/open]Code[close]a[/close][open]a[/open]VBCode[close]a[/close]
    4. code here
    5. [open]a[/open]/VBCode[close]a[/close]
    6. lots of blank lines to open the code box up
    7. [open]a[/open]/Code[close]a[/close]
    8.  
    9.  
    10. Option Explicit
    11.  
    12. Private Const LF_FACESIZE = 32
    13.  
    14. Private Type LOGFONT
    15.     lfHeight As Long
    16.     lfWidth As Long
    17.     lfEscapement As Long
    18.     lfOrientation As Long
    19.     lfWeight As Long
    20.     lfItalic As Byte
    21.     lfUnderline As Byte
    22.     lfStrikeOut As Byte
    23.     lfCharSet As Byte
    24.  
    25. etc.
    The most difficult part of developing a program is understanding the problem.
    The second most difficult part is deciding how you're going to solve the problem.
    Actually writing the program (translating your solution into some computer language) is the easiest part.

    Please indent your code and use [HIGHLIGHT="VB"] [/HIGHLIGHT] tags around it to make it easier to read.

    Please Help Us To Save Ana

  14. #14
    Super Moderator RobDog888's Avatar
    Join Date
    Apr 2001
    Location
    LA, Calif. Raiders #1 AKA:Gangsta Yoda™
    Posts
    60,622

    Re: Forms Captions (Or Image)

    I remember doing some right aligning of menus as it was a built in feature. Perhaps something similar for the titlebar?
    VB/Office Guru™ (AKA: Gangsta Yoda®)
    I dont answer coding questions via PM. Please post a thread in the appropriate forum.

    Microsoft MVP 2006-2011
    Office Development FAQ (C#, VB.NET, VB 6, VBA)
    Senior Jedi Software Engineer MCP (VB 6 & .NET), BSEE, CET
    If a post has helped you then Please Rate it!
    Reps & Rating PostsVS.NET on Vista Multiple .NET Framework Versions Office Primary Interop AssembliesVB/Office Guru™ Word SpellChecker™.NETVB/Office Guru™ Word SpellChecker™ VB6VB.NET Attributes Ex.Outlook Global Address ListAPI Viewer utility.NET API Viewer Utility
    System: Intel i7 6850K, Corsair H100i v2 water cooler, Geforce GTX1060, Samsung M.2 500 GB & SATA 500 GB, 32 GBs DDR4 3300 Quad Channel RAM, 2 Viewsonic 24" LCDs, Windows 10, Office 2010, VS 2010

  15. #15

  16. #16
    Oi, fat-rag! bushmobile's Avatar
    Join Date
    Mar 2004
    Location
    on the poop deck
    Posts
    5,592

    Re: Forms Captions (Or Image)

    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.

  17. #17
    Super Moderator RobDog888's Avatar
    Join Date
    Apr 2001
    Location
    LA, Calif. Raiders #1 AKA:Gangsta Yoda™
    Posts
    60,622

    Re: Forms Captions (Or Image)

    So then it would be centered text?
    VB/Office Guru™ (AKA: Gangsta Yoda®)
    I dont answer coding questions via PM. Please post a thread in the appropriate forum.

    Microsoft MVP 2006-2011
    Office Development FAQ (C#, VB.NET, VB 6, VBA)
    Senior Jedi Software Engineer MCP (VB 6 & .NET), BSEE, CET
    If a post has helped you then Please Rate it!
    Reps & Rating PostsVS.NET on Vista Multiple .NET Framework Versions Office Primary Interop AssembliesVB/Office Guru™ Word SpellChecker™.NETVB/Office Guru™ Word SpellChecker™ VB6VB.NET Attributes Ex.Outlook Global Address ListAPI Viewer utility.NET API Viewer Utility
    System: Intel i7 6850K, Corsair H100i v2 water cooler, Geforce GTX1060, Samsung M.2 500 GB & SATA 500 GB, 32 GBs DDR4 3300 Quad Channel RAM, 2 Viewsonic 24" LCDs, Windows 10, Office 2010, VS 2010

  18. #18
    PowerPoster RhinoBull's Avatar
    Join Date
    Mar 2004
    Location
    New Amsterdam
    Posts
    24,135

    Re: Forms Captions (Or Image)

    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.

  19. #19
    PowerPoster gavio's Avatar
    Join Date
    Feb 2006
    Location
    GMT+1
    Posts
    4,462

    Re: Forms Captions (Or Image)

    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

  20. #20
    PowerPoster RhinoBull's Avatar
    Join Date
    Mar 2004
    Location
    New Amsterdam
    Posts
    24,135

    Re: Forms Captions (Or Image)

    Bush's code reposted for myself for better readability
    VB Code:
    1. Option Explicit
    2.  
    3. Private Const LF_FACESIZE = 32
    4.  
    5. Private Type LOGFONT
    6.     lfHeight As Long
    7.     lfWidth As Long
    8.     lfEscapement As Long
    9.     lfOrientation As Long
    10.     lfWeight As Long
    11.     lfItalic As Byte
    12.     lfUnderline As Byte
    13.     lfStrikeOut As Byte
    14.     lfCharSet As Byte
    15.     lfOutPrecision As Byte
    16.     lfClipPrecision As Byte
    17.     lfQuality As Byte
    18.     lfPitchAndFamily As Byte
    19.     lfFaceName(1 To LF_FACESIZE) As Byte
    20. End Type
    21.  
    22. Private Type NONCLIENTMETRICS
    23.     cbSize As Long
    24.     iBorderWidth As Long
    25.     iScrollWidth As Long
    26.     iScrollHeight As Long
    27.     iCaptionWidth As Long
    28.     iCaptionHeight As Long
    29.     lfCaptionFont As LOGFONT
    30.     iSMCaptionWidth As Long
    31.     iSMCaptionHeight As Long
    32.     lfSMCaptionFont As LOGFONT
    33.     iMenuWidth As Long
    34.     iMenuHeight As Long
    35.     lfMenuFont As LOGFONT
    36.     lfStatusFont As LOGFONT
    37.     lfMessageFont As LOGFONT
    38. End Type
    39.  
    40. Private Type RECT
    41.     Left As Long
    42.     Top As Long
    43.     Right As Long
    44.     Bottom As Long
    45. End Type
    46.  
    47. ' SubClassing
    48. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
    49.     ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    50.    
    51. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
    52.     ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, _
    53.     ByVal lParam As Long) As Long
    54.  
    55. Private Const GWL_WNDPROC = (-4)
    56.  
    57. Private Const WM_NCACTIVATE = &H86
    58. Private Const WM_NCPAINT = &H85
    59.  
    60. Private lPrevProc As Long
    61.  
    62. ' Positioning & Drawing
    63. Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _
    64.     ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
    65.  
    66. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    67.  
    68. Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    69. Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
    70. Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    71. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    72. Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
    73. 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
    74. Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    75. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    76. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    77.  
    78. Private Const SPI_GETNONCLIENTMETRICS = 41
    79. Private Const LOGPIXELSY = 90
    80. Private Const COLOR_ACTIVECAPTION = 2
    81. Private Const COLOR_CAPTIONTEXT = 9
    82.  
    83. Public sExtraText As String
    84. Private oForm As Form
    85. Private ncm As NONCLIENTMETRICS
    86.  
    87. Private Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    88.     Dim wDC As Long, r As RECT, lFont As Long, lOldFont As Long
    89.     Dim lWidth As Long, sngCharWidth As Single, sngTextWidth As Single, lNum As Long
    90.    
    91.     WndProc = CallWindowProc(lPrevProc, hwnd, Msg, wParam, lParam)
    92.     Select Case Msg
    93.         Case WM_NCPAINT, WM_NCACTIVATE
    94.             ' calculate the area we have to play with (15 is just padding)
    95.             lWidth = (oForm.Width \ Screen.TwipsPerPixelX) - 16 - ncm.iCaptionWidth * 3 - ncm.iBorderWidth * 2 - 15
    96.    
    97.             sngCharWidth = oForm.TextWidth(" ") / Screen.TwipsPerPixelX
    98.             sngTextWidth = oForm.TextWidth(oForm.Caption & sExtraText) / Screen.TwipsPerPixelX
    99.            
    100.             If lWidth - sngTextWidth > 0 Then
    101.                 wDC = GetWindowDC(hwnd)
    102.                
    103.                 ' this should make the back transparent (but doesn't)
    104.                 SetBkColor wDC, 1& 'GetSysColor(COLOR_ACTIVECAPTION)
    105.                 SetTextColor wDC, GetSysColor(COLOR_CAPTIONTEXT)
    106.                
    107.                 lFont = CreateFontIndirect(ncm.lfCaptionFont)
    108.                 lOldFont = SelectObject(wDC, lFont)
    109.                
    110.                 With r
    111.                     .Top = ncm.iBorderWidth * 6
    112.                     .Left = lWidth + 16 - (oForm.TextWidth(sExtraText) / Screen.TwipsPerPixelX)
    113.                     .Bottom = oForm.TextHeight(sExtraText) ' / Screen.TwipsPerPixelY
    114.                     .Right = oForm.TextWidth(sExtraText) ' / Screen.TwipsPerPixelX
    115.                 End With
    116.                
    117.                 DrawText wDC, sExtraText, Len(sExtraText), r, 0&
    118.                
    119.                 ' clear up
    120.                 SelectObject wDC, lOldFont
    121.                 DeleteObject lFont
    122.                 ReleaseDC hwnd, wDC
    123.             End If
    124.     End Select
    125. End Function
    126.  
    127. Public Sub AddExtraTextSubClass(ByRef oFrm As Form)
    128.     Dim sFont As String, lPos As Long
    129.    
    130.     Set oForm = oFrm
    131.     lPrevProc = SetWindowLong(oForm.hwnd, GWL_WNDPROC, AddressOf WndProc)
    132.    
    133.     ncm.cbSize = Len(ncm)
    134.     SystemParametersInfo SPI_GETNONCLIENTMETRICS, ncm.cbSize, ncm, 0&
    135.     sFont = StrConv(ncm.lfCaptionFont.lfFaceName, vbUnicode)
    136.     lPos = InStr(sFont, vbNullChar)
    137.     If lPos Then sFont = Left$(sFont, lPos - 1)
    138.     oFrm.FontName = sFont
    139.     oFrm.FontSize = (-ncm.lfCaptionFont.lfHeight * 72) / GetDeviceCaps(oForm.hdc, LOGPIXELSY)
    140. End Sub
    141.  
    142. Public Sub UnSubClass(ByRef oFrm As Form)
    143.     SetWindowLong oFrm.hwnd, GWL_WNDPROC, lPrevProc
    144.     Set oForm = Nothing
    145. End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width