Add an icon/image to the caption in a userform

[navb]

Hi
I need to add a company logo to the caption of my userform. How can this be done ?

 

[John_w]

See the Can you insert an image (jpg) in the caption (title) - Microsoft Community Answer.

 

[navb]

See the Can you insert an image (jpg) in the caption (title) - Microsoft Community Answer.

Thanks John
The code works fine . But my guess is that it will not work if I run this on someone else's system. This is because the code requires you to explicitly mention the path of the .ico file. Is there a way out ? Can I paste the .ico file in my current workbook and then set this as the path during runtine ?

 

[navb]

Also it will be great if anyone can explain the following code which inserts the image into the caption bar of a user form.

Private Declare Function FindWindow _
    Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
 
Private Declare Function ExtractIcon _
    Lib "shell32.dll" Alias "ExtractIconA" _
   (ByVal hInst As Long, _
    ByVal lpszExeFileName As String, _
    ByVal nIconIndex As Long) As Long
 
Private Declare Function SendMessage _
    Lib "user32" Alias "SendMessageA" _
   (ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Integer, _
    ByVal lParam As Long) As Long
 
Private Const WM_SETICON = &H80
 
Private Sub UserForm_Initialize()
    Dim strIconPath As String
    Dim lngIcon As Long
    Dim lnghWnd As Long
    ' Change to the path and filename of an icon file
    strIconPath = "C:\Users\AD\Desktop\XYZ.ico"
    ' Get the icon from the source
    lngIcon = ExtractIcon(0, strIconPath, 0)
    ' Get the window handle of the userform
    lnghWnd = FindWindow("ThunderDFrame", Me.Caption)
    'Set the big (32x32) and small (16x16) icons
    SendMessage lnghWnd, WM_SETICON, True, lngIcon
    SendMessage lnghWnd, WM_SETICON, False, lngIcon
End Sub

 

[RoryA]

Those are windows API calls to extract the icon image from the file, locate the correct window, then tell it to use the icon as its icon.

 

[navb]

Those are windows API calls to extract the icon image from the file, locate the correct window, then tell it to use the icon as its icon.

Can you please help me in modifying the code ? Instead of inserting an image , I want first 3 letters of the caption to be colored red and rest all the letters to be colored blue ? Is it possible ?

 

[RoryA]

Honestly, I have no idea - I imagine so using a lot of API calls but I suspect it will be horribly complicated. In my opinion it would not be worth the effort.

 

[navb]

What does "ThunderDFrame" do in the above code ? Are there any books which cover the Windows API through VBA in detail ?

 

[RoryA]

ThunderDFrame is the class name of the Userform window.

I am not aware of any API references for VBA specifically, but I would recommend Dan Appleman's VB6 API reference books. The syntax is pretty much the same.

 

[Jaafar Tribak]

Can you please help me in modifying the code ? Instead of inserting an image , I want first 3 letters of the caption to be colored red and rest all the letters to be colored blue ? Is it possible ?

Workbook example

Hi, I have been working on this for the last couples of days and after some endless nasty crashings I hope I have managed to make this happen.

Basically the ShowFormatedUserForm sub allows the user to easily change the color/gradient of the entire userform titlebar and also allows to change the font/color of individual caption letters.

Code for future reference :

1- Place this code in a Standard Module :

Option Explicit
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
    lbHatch As Long
End Type
 
Private Type PAINTSTRUCT
    hdc As Long
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(32) As Byte
End Type
 
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 * 32
End Type

Private Type FontAttributes
    FONT_NAME As String
    FONT_SIZE As Long
    FONT_BOLD As Boolean
    FONT_ITALIC As Boolean
    FONT_UNDERLINE As Boolean
End Type

Private Type TRIVERTEX
    x As Long
    y As Long
    Red As Integer
    Green As Integer
    Blue As Integer
    Alpha As Integer
End Type

Private Type GRADIENT_RECT
    UpperLeft As Long
    LowerRight As Long
End Type
 
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
 
Private Declare Function GetWindowDC Lib "user32" _
 (ByVal hwnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, _
ByVal hdc As Long) As Long
 
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" _
(ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
 
Private Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
 
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
 
Private Declare Function SetWindowsHookEx Lib _
"user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
 
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
 
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
 
Private Declare Function GetCurrentThreadId Lib "kernel32" _
() As Long
 
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 Declare Function GetClassName Lib "user32" _
Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
 
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
 
Private Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, _
ByVal crColor As Long) As Long
 
Private Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
 
Private Declare Function FillRect Lib "User32.dll" _
(ByVal hdc As Long, _
ByRef lpRect As RECT, _
ByVal hBrush As Long) As Long
 
Private Declare Function SetRect Lib "user32" _
(lpRect As RECT, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
 
Private Declare Function GetWindowRect Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpRect As RECT) As Long
 
Private Declare Function BeginPaint Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function EndPaint Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPaint As PAINTSTRUCT) As Long
 
Private Declare Function InvalidateRect Lib "User32.dll" _
(ByVal hwnd As Long, _
ByVal lpRect As Long, _
ByVal bErase As Long) As Long
 
Private Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long

Private Declare Function SetMapMode Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nMapMode 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 Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
(dst As Any, ByVal iLen As Long)

Private Declare Function GetTextColor Lib "gdi32" ( _
ByVal hdc As Long) As Long

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

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As _
  Long, ByVal y As Long) As Long
  
Private Declare Function IsBadWritePtr Lib "kernel32" _
(ByVal lp As Long, ByVal ucb As Long) As Long

Private Declare Function GradientFillRect Lib "msimg32" Alias "GradientFill" _
(ByVal hdc As Long, pVertex As TRIVERTEX, ByVal dwNumVertex As Long, _
pMesh As GRADIENT_RECT, ByVal dwNumMesh As Long, ByVal dwMode As Long) As Long

 Private Declare Function PtInRect Lib "user32" _
 (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
 
Private Declare Function ScreenToClient Lib "User32.dll" _
(ByVal hwnd As Long, _
ByRef lpPoint As POINTAPI) As Long

Private Declare Function DrawFrameControl Lib "user32" _
(ByVal hdc As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long

Private Declare Function OffsetRect Lib "user32" _
(lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const DT_CALCRECT = &H400
Private Const WH_CBT As Long = 5
Private Const HCBT_ACTIVATE As Long = 5
Private Const GWL_WNDPROC As Long = -4
Private Const WM_ACTIVATE As Long = &H6
Private Const WM_PAINT As Long = &HF&
Private Const WM_SHOWWINDOW As Long = &H18
Private Const WM_EXITSIZEMOVE As Long = &H232
Private Const WM_DESTROY As Long = &H2
Private Const SM_CYCAPTION As Long = 4
Private Const COLOR_ACTIVECAPTION = 2
Private Const GRADIENT_FILL_RECT_H As Long = &H0
Private Const WM_SYSCOMMAND = &H112
Private Const SM_CXSIZE = 30
Private Const SM_CYSIZE = 31
Private Const WS_SYSMENU = &H80000
Private Const GWL_STYLE As Long = (-16)

Private tFontAttr  As FontAttributes
Private tr2 As RECT
Private tRect As RECT
Private lPrevWnd As Long
Private lhHook As Long
Private bHookEnabled As Boolean
Private oForm As Object
Private bGradientFill As Boolean
Private lCharColorsPtr As Long
Private bCreateFont As Boolean
Private lDefaultFontColor As Long
Private sFontName As String
Private lFontSize As Long
Private bFontBold As Boolean
Private bFontItalic     As Boolean
Public bFontUnderline As Boolean
Private sCaptionText As String
Private lTitleBarColor As Long
Private lFontColour As Long
Private aCharColors() As Variant


Public Sub ShowFormatedUserForm( _
    ByVal Form As Object, _
    Optional ByVal TitleBarColor As Long, _
    Optional ByVal GradientFill As Boolean, _
    Optional ByVal FontAttributesPtr As Long, _
    Optional CharColorsPtr As Long _
)
    Call HookUserForm(ByVal Form, _
        ByVal TitleBarColor, _
        ByVal GradientFill, _
        ByVal FontAttributesPtr, _
        CharColorsPtr _
    )
End Sub


Private Sub HookUserForm _
 (ByVal Form As Object, ByVal TitleBarColour As Long, _
 ByVal GradientFill As Boolean, ByVal FontAttributesPtr As Long, _
  CharColorsPtr As Long)
    If Not bHookEnabled Then
        Set oForm = Form
        sCaptionText = Form.Caption
        Form.Caption = vbNullString
        lCharColorsPtr = CharColorsPtr
        bGradientFill = GradientFill
        lTitleBarColor = IIf(TitleBarColour = 0, _
        GetSysColor(COLOR_ACTIVECAPTION), TitleBarColour)
        lDefaultFontColor = IIf(CharColorsPtr = 0, GetSysColor(9), 0)
        If IsBadWritePtr(FontAttributesPtr, 4) = 0 Then
            If FontAttributesPtr <> 0 Then
                CopyMemory ByVal tFontAttr, ByVal FontAttributesPtr, LenB(tFontAttr)
                With tFontAttr
                    sFontName = .FONT_NAME
                    lFontSize = .FONT_SIZE
                    bFontBold = .FONT_BOLD
                    bFontItalic = .FONT_ITALIC
                    bFontUnderline = .FONT_UNDERLINE
                End With
                bCreateFont = True
            Else
                bCreateFont = False
            End If
        End If
        If IsBadWritePtr(CharColorsPtr, 4) = 0 Then
            If CharColorsPtr <> 0 Then
                ReDim aCharColors(Len(sCaptionText))
                CopyMemory aCharColors(0), ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1)
                ZeroMemory ByVal CharColorsPtr, 16 * (UBound(aCharColors) + 1)
            Else
                Erase aCharColors()
            End If
        End If
        lhHook = SetWindowsHookEx _
        (WH_CBT, AddressOf HookProc, 0, GetCurrentThreadId)
        bHookEnabled = True
        Form.Show
    Else
        MsgBox "The hook is already set.", vbInformation
    End If
    
End Sub
 
Private Function HookProc _
(ByVal idHook As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
    Dim sBuffer As String
    Dim lRetVal As Long
    Dim lDc As Long
    
    If idHook = HCBT_ACTIVATE Then
        sBuffer = Space(256)
        lRetVal = GetClassName(wParam, sBuffer, 256)
        If Left(sBuffer, lRetVal) = "ThunderDFrame" Or _
        Left(sBuffer, lRetVal) = "ThunderXFrame" Then
            lDc = GetWindowDC(wParam)
             ReleaseDC wParam, lDc
            lPrevWnd = SetWindowLong _
            (wParam, GWL_WNDPROC, AddressOf CallBackProc)
            UnhookWindowsHookEx lhHook
            bHookEnabled = False
        End If
    End If
    HookProc = CallNextHookEx _
    (lhHook, idHook, ByVal wParam, ByVal lParam)
End Function
 
Private Function CallBackProc _
(ByVal hwnd As Long, ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
      Static i As Long
      Dim lDc As Long

    Dim lStyle As Long
    Dim loword As Long
    Dim hiword As Long
    Dim tPt As POINTAPI
'    Dim j
'    Dim TextSize As POINTAPI
    Dim x As Long
    Dim pt As POINTAPI
    Dim tr As RECT
'    Dim ret As Long
    
    On Error Resume Next
    GetWindowRect hwnd, tRect
    Select Case Msg
        Case WM_PAINT, WM_ACTIVATE
            If Msg = WM_ACTIVATE Then
                lStyle = GetWindowLong(hwnd, GWL_STYLE)
                SetWindowLong hwnd, GWL_STYLE, (lStyle And Not WS_SYSMENU)
            End If
            lDc = GetWindowDC(hwnd)
            Call DrawTitleBar(hwnd, lTitleBarColor)
            SetBkMode lDc, 1
            If bCreateFont Then
                CreateFont lDc
            End If
            For i = 1 To Len(sCaptionText)
                If lCharColorsPtr = 0 Then
                    SetTextColor lDc, lDefaultFontColor
                Else
                    SetTextColor lDc, aCharColors(i - 1)
                End If
                SetRect tr, 0, 0, 0, 0
                DrawText lDc, Mid(sCaptionText, i, 1), _
                Len(Mid(sCaptionText, i, 1)), tr, DT_CALCRECT
                If x = 0 Then x = 4
                TextOut lDc, x, GetSystemMetrics(SM_CYCAPTION) / 3, _
                Mid(sCaptionText, i, 1), Len(Mid(sCaptionText, i, 1))
                x = x + Abs(tr.Right - tr.Left)
            Next
            lFontColour = GetTextColor(lDc)
            ReleaseDC hwnd, lDc
            InvalidateRect hwnd, 0, 0
        Case WM_EXITSIZEMOVE, WM_SHOWWINDOW
            Call DrawTitleBar(hwnd, lTitleBarColor)
            InvalidateRect hwnd, 0, 0
        Case WM_SYSCOMMAND
            GetHiLoword lParam, loword, hiword
            tPt.x = loword
            tPt.y = hiword
            ScreenToClient hwnd, tPt
            If PtInRect(tr2, tPt.x, -tPt.y) Then
                Unload oForm
            End If
        Case WM_DESTROY
            SetWindowLong hwnd, GWL_WNDPROC, lPrevWnd
            bGradientFill = False
            lCharColorsPtr = 0
            bCreateFont = False
            lDefaultFontColor = 0
            sFontName = vbNullString
            lFontSize = 0
            bFontBold = False
            bFontItalic = False
            bFontUnderline = False
            sCaptionText = vbNullString
            lTitleBarColor = 0
            lFontColour = 0
            Erase aCharColors()
            Set oForm = Nothing
    End Select
    CallBackProc = CallWindowProc _
    (lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function
 
Private Sub CreateFont(DC As Long)
    Dim uFont As LOGFONT
    Dim lNewFont As Long
    
    With uFont
        .lfFaceName = sFontName & Chr$(0)
        .lfWidth = lFontSize
        .lfWeight = IIf(bFontBold, 900, 100)
        .lfItalic = bFontItalic
        .lfUnderline = bFontUnderline
    End With
    lNewFont = CreateFontIndirect(uFont)
    DeleteObject (SelectObject(DC, lNewFont))
End Sub

Private Sub ConvertLongToRGB(ByVal Value As Long, r As Byte, g As Byte, b As Byte)
    r = Value Mod 256
    g = Int(Value / 256) Mod 256
    b = Int(Value / 256 / 256) Mod 256
End Sub

Private Function LongToUShort(Unsigned As Long) As Double
    LongToUShort = CInt(Unsigned - &H10000)
End Function

Private Function TransfCol(ByVal Col As Long) As Double
    Dim a As Double
    
    If Col = 0 Then
        TransfCol = 0
    ElseIf Col > 127 Then
        a = 256 - Col
        TransfCol = -(256 * a)
    Else
        a = Col
        TransfCol = 256 * a
    End If
End Function
 
Private Sub DrawTitleBar _
(lhwnd As Long, ByVal MyColor As Long)
    Dim tPS As PAINTSTRUCT
    Dim tLB As LOGBRUSH
    Dim tr As RECT
    Dim lDc As Long
    Dim l As Long
    Dim hBrush As Long
    Dim vert(2) As TRIVERTEX
    Dim tPt As GRADIENT_RECT
    Dim r As Byte, g As Byte, b As Byte
    
    Call BeginPaint(lhwnd, tPS)
        lDc = GetWindowDC(lhwnd)
        tLB.lbColor = MyColor
        hBrush = CreateBrushIndirect(tLB)
        Call GetWindowRect(lhwnd, tr)
        SetRect tr, 0, 0, tr.Right, tr.Bottom
        SetRect tr2, 0, 5, _
        GetSystemMetrics(SM_CXSIZE), GetSystemMetrics(SM_CYSIZE) + tr.Bottom
        OffsetRect tr2, tRect.Right - tRect.Left - GetSystemMetrics(SM_CXSIZE), 0
        FillRect lDc, tr, hBrush
        If bGradientFill Then
            ConvertLongToRGB MyColor, r, g, b
            With vert(0)
                .x = 0
                .y = 0
                .Red = TransfCol(r)
                .Green = TransfCol(g)
                .Blue = TransfCol(b)
                .Alpha = TransfCol(0)
            End With
            With vert(1)
                .x = tr2.Right
                .y = tr2.Bottom
                .Red = TransfCol(0)
                .Green = TransfCol(0)
                .Blue = TransfCol(0)
                .Alpha = TransfCol(0)
            End With
            tPt.UpperLeft = 0
            tPt.LowerRight = 1
            GradientFillRect lDc, vert(0), 2, tPt, 1, GRADIENT_FILL_RECT_H
        End If
        Call DeleteObject(hBrush)
        SetRect tr2, tr2.Right - GetSystemMetrics(SM_CXSIZE), 0, _
        tr2.Right, GetSystemMetrics(SM_CYSIZE)
        OffsetRect tr2, -4, 2
        DrawFrameControl lDc, tr2, DFC_CAPTION, DFCS_CAPTIONCLOSE
        ReleaseDC lhwnd, lDc
    Call EndPaint(lhwnd, tPS)
End Sub

Private Sub GetHiLoword _
(lParam As Long, ByRef loword As Long, ByRef hiword As Long)
    loword = lParam And &HFFFF&
    hiword = lParam \ &H10000 And &HFFFF&
End Sub

2- And this his is an example of how to build and show the Formatted userform whose caption title is: "UserForm1 - Demo" ( Code goes in a Standrad Module ) :

Option Explicit

Private Type FontAttributes
    FONT_NAME As String
    FONT_SIZE As Long
    FONT_BOLD As Boolean
    FONT_ITALIC As Boolean
    FONT_UNDERLINE As Boolean
End Type

Sub test()

    Dim tFontAttr As FontAttributes
    Dim aCharColors() As Variant
    Dim lTitleBarColor As Long
    
   [COLOR=#008000] 'define a random title bar color[/COLOR]
    lTitleBarColor = RGB(0, 255, 0)
    
   [COLOR=#008000] 'build the caption font structure[/COLOR]
    With tFontAttr
        .FONT_NAME = "Arial" '"Trebuchet MS"
        .FONT_SIZE = 8
        .FONT_BOLD = True
        .FONT_ITALIC = False
        .FONT_UNDERLINE = False
    End With
    
   [COLOR=#008000] 'build the caption individual character colors[/COLOR]
        ReDim aCharColors(Len(UserForm1.Caption))[COLOR=#008000] '===> (=16 chars in this case)[/COLOR]
        aCharColors(0) = vbRed                   'U
        aCharColors(1) = vbRed                   's
        aCharColors(2) = vbRed                   'e
        aCharColors(3) = vbRed                   'r
        aCharColors(4) = vbBlue                  'F
        aCharColors(5) = vbBlue                  'o
        aCharColors(6) = vbBlue                  'r
        aCharColors(7) = vbBlue                  'm
        aCharColors(8) = vbYellow                '1
        aCharColors(9) = 0
        aCharColors(10) = vbRed                   '-
        aCharColors(11) = 0
        aCharColors(10) = vbWhite                'D
        aCharColors(12) = vbWhite                'e
        aCharColors(13) = vbWhite                'm
        aCharColors(14) = vbWhite                '0
        aCharColors(15) = vbWhite                '0
        
    
    [COLOR=#008000]'display the userform[/COLOR]
    Call ShowFormatedUserForm( _
            Form:=UserForm1, _
            TitleBarColor:=lTitleBarColor, _
            GradientFill:=True, _
            FontAttributesPtr:=VarPtr(tFontAttr), _
            CharColorsPtr:=VarPtr(aCharColors(0)) _
    )

End Sub

Code written and tested on Excel 2007 Win XP.


NB: Works only with Modal userforms