Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const BM_SETSTYLE As Long = &HF4
Public Const BS_GROUPBOX As Long = &H7&

'---------------------------------------------------------------------------------------------------
'Author: Jottum  and Gibra
'---------------------------------------------------------------------------------------------------

'API Declarations.
 
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
 
Private Const LF_FACESIZE = 32
 
Private Type FONTSLOG
  flfHeight As Long
  flfWidth As Long
  flfEscapement As Long
  flfOrientation As Long
  flfWeight As Long
  flfItalic As Byte
  flfUnderline As Byte
  flfStrikeOut As Byte
  flfCharSet As Byte
  flfOutPrecision As Byte
  flfClipPrecision As Byte
  flfQuality As Byte
   flfPitchAndFamily As Byte
  flfFaceName As String * LF_FACESIZE
End Type
 
Private Declare Function GetDC 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 GetClientRect Lib "user32" _
   (ByVal hwnd As Long, lpRect As RECT) As Long
 
Private Declare Function InflateRect Lib "user32" _
   (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
 
Declare Function GetDesktopWindow Lib "user32" _
   () As Long
    
Private Declare Function DrawEdge Lib "user32" _
   (ByVal hDC As Long, qrc As RECT, ByVal edge As Long, _
    ByVal grfFlags 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 BitBlt Lib "gdi32" _
   (ByVal hdcDest As Long, ByVal xDest As Long, ByVal yDest As Long, _
    ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As Long, _
    ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
     
Private Declare Function DrawFocusRect Lib "user32" _
   (ByVal hDC As Long, lpRect As RECT) As Long
     
 
'Theme API Declarations.
 
Private Declare Function GetThemeFont Lib "uxtheme.dll" ( _
   ByVal hTheme As Long, _
   ByVal hDC As Long, _
   ByVal iPartId As Long, _
   ByVal iStateId As Long, _
   ByVal iPropId As Long, _
   tLogFont As FONTSLOG) As Long
 
Private Declare Function OpenThemeData Lib "uxtheme.dll" _
   (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
    
Private Declare Function IsThemeActive Lib "uxtheme.dll" _
   () As Boolean
 
Private Declare Function CloseThemeData Lib "uxtheme.dll" _
   (ByVal hTheme As Long) As Long
    
Private Declare Function DrawThemeBackground Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal lHdc As Long, _
    ByVal iPartId As Long, ByVal iStateId As Long, _
    pRect As RECT, pClipRect As RECT) As Long
     
Private Declare Function DrawThemeText Lib "uxtheme.dll" _
   (ByVal hTheme As Long, ByVal hDC As Long, ByVal iPartId As Long, _
    ByVal iStateId As Long, ByVal pszText As Long, _
    ByVal iCharCount As Long, ByVal dwTextFlag As Long, _
    ByVal dwTextFlags2 As Long, pRect As RECT) As Long
     
Private Declare Function GetThemeRect Lib "uxtheme.dll" ( _
   ByVal hTheme As Long, _
   ByVal iPartId As Long, _
   ByVal iStateId As Long, _
   ByVal iPropId As Long, _
   ByRef pRect As RECT) As Long
     
'Types, Enums and Constants...
         
'Tab constants.
Private Enum ThemeTabParts
   TAB_TABITEM = 1
   TAB_TABITEMLEFTEDGE = 2
   TAB_TABITEMRIGHTEDGE = 3
   TAB_TABITEMBOTHEDGE = 4
   TAB_TOPTABITEM = 5
   TAB_TOPTABITEMLEFTEDGE = 6
   TAB_TOPTABITEMRIGHTEDGE = 7
   TAB_TOPTABITEMBOTEDGE = 8
   TAB_PANE = 9
   TAB_BODY = 10
End Enum
 
Private Enum ThemeTabItemStates
   TIS_NORMAL = 1
   TIS_HOT = 2
   TIS_SELECTED = 3
   TIS_DISABLED = 4
   TIS_FOCUSED = 5
End Enum
 
Private Enum ThemeTabItemLeftEdgeStates
   TILES_NORMAL = 1
   TILES_HOT = 2
   TILES_SELECTED = 3
    TILES_DISABLED = 4
   TILES_FOCUSED = 5
End Enum
 
Private Enum ThemeTabItemRightEdgeStates
   TIRES_NORMAL = 1
   TIRES_HOT = 2
   TIRES_SELECTED = 3
   TIRES_DISABLED = 4
   TIRES_FOCUSED = 5
End Enum
 
Private Enum ThemeTabItemBotEdgeStates
   TIBES_NORMAL = 1
   TIBES_HOT = 2
   TIBES_SELECTED = 3
   TIBES_DISABLED = 4
   TIBES_FOCUSED = 5
End Enum
 
Private Enum ThemeTopTabItemStates
   TTIS_NORMAL = 1
   TTIS_HOT = 2
   TTIS_SELECTED = 3
   TTIS_DISABLED = 4
   TTIS_FOCUSED = 5
End Enum
 
Private Enum ThemeTopTabItemLeftEdgeStates
   TTILES_NORMAL = 1
   TTILES_HOT = 2
   TTILES_SELECTED = 3
   TTILES_DISABLED = 4
   TTILES_FOCUSED = 5
End Enum
 
Private Enum ThemeTopTabItemRightEdgeStates
   TTIRES_NORMAL = 1
   TTIRES_HOT = 2
   TTIRES_SELECTED = 3
   TTIRES_DISABLED = 4
   TTIRES_FOCUSED = 5
End Enum
 
Private Enum ThemeTopTabItemBotEdgeStates
   TTIBES_NORMAL = 1
   TTIBES_HOT = 2
   TTIBES_SELECTED = 3
   TTIBES_DISABLED = 4
   TTIBES_FOCUSED = 5
End Enum
 
'DrawTabThemeBackground() constants.
Public Const DTTB_HIDEPANE = True
Public Const DTTB_SHOWPANE = False                    'Default if omitted
Public Const DTTB_SHOWERRMSG = True
Public Const DTTB_HIDERRMSG = False                   'Default if omitted
Public Const DTTB_HIDEBODY = True                     'Default is False, show the body
 
'IsThemed() constant.
Public Const IT_SHOWERRMSG = True
 
'Miscellaneous
Private Const DT_LEFT = &H0
Private Const DT_TOP = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4
Private Const DT_BOTTOM = &H8&
Private Const DT_SINGLELINE = &H20
 
Private Const TMT_FONT = 210
 
'\DrawEdge
Private Const BDR_RAISEDOUTER = &H1
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const BDR_SUNKENINNER = &H8
 
Private Const BDR_OUTER = &H3
Private Const BDR_INNER = &HC
Private Const BDR_RAISED = &H5
Private Const BDR_SUNKEN = &HA
 
Private Const EDGE_RAISED = (BDR_RAISEDOUTER Or BDR_RAISEDINNER)
Private Const EDGE_SUNKEN = (BDR_SUNKENOUTER Or BDR_SUNKENINNER)
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const EDGE_BUMP = (BDR_RAISEDOUTER Or BDR_SUNKENINNER)
 
Private Const BF_LEFT = &H1
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private Const BF_BOTTOM = &H8
 
Private Const BF_TOPLEFT = (BF_TOP Or BF_LEFT)
Private Const BF_TOPRIGHT = (BF_TOP Or BF_RIGHT)
Private Const BF_BOTTOMLEFT = (BF_BOTTOM Or BF_LEFT)
Private Const BF_BOTTOMRIGHT = (BF_BOTTOM Or BF_RIGHT)
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
 
 
 Public WinVersion As Long   '/ la versione del OS
'/ GetVersionEx modificata
Private Declare Function GetVersionEx2 Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO2) As Long
Private Const VER_PLATFORM_WIN32_NT = 2
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32s = 0
Private Const MAX_PATH = 260
Public Const UNKNOWN_OS = 0
Public Const WINDOWS_NT_3_51 = 1
Public Const WINDOWS_95 = 2
Public Const WINDOWS_NT_4 = 3
Public Const WINDOWS_98 = 4
Public Const WINDOWS_2000 = 5
Public Const WINDOWS_XP = 6  ' mia

'' UDT per determinare OS
Private Type OSVERSIONINFO2
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformID As Long
    szCSDVersion As String * 128
End Type

Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type

Public Type POINTAPI
  x As Long
  y As Long
End Type

Public Type Size
    cx As Long
    cy As Long
End Type

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetParent Lib "user32.dll" (ByVal hwnd As Long) As Long


Public Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Sub ChangeShapeToButton(frm As Form)
On Error GoTo ErrHandler
    Dim ctl As Control
    Dim cmd As CommandButton
    For Each ctl In frm.Controls
        If TypeOf ctl Is Shape Then
            If ctl.Index >= 0 Then
                Set cmd = frm.Controls.Add("vb.CommandButton", "cmd" & ctl.Name & ctl.Index)
                With cmd
                    .Visible = True
                    .Caption = ctl.Tag
		    .TabStop = False
                    Set .Container = ctl.Container
                    .Move ctl.Left, ctl.Top, ctl.Width, ctl.Height
                    .ZOrder 1
                    ctl.Visible = False
                    SendMessage cmd.hwnd, BM_SETSTYLE, BS_GROUPBOX, 0
                End With
            End If
        End If
    Next
    Exit Sub
ErrHandler:
    If Err.Number <> 343 Then
        MsgBox Err.Description, vbCritical, "Error"
    End If
End Sub


Public Function DrawTabThemeBackground(Obj As Object, _
                                       Optional lBodyOnly As Boolean = False, _
                                       Optional ShowErrMsg As Boolean = False, _
                                       Optional TabTitle As String = vbNullString, _
                                       Optional lNoBody As Boolean = False) As Boolean
 
On Error GoTo ThemeError                              'Catch errors.
 
   Dim hTheme As Long                                 'Declare local variables
   Dim lR As Long
   Dim tR As RECT
   Dim tR2 As RECT
   Dim tTextR As RECT
   Dim cControl As Control
   Dim lTmp As Long
   Dim strLength As Long
    
   If lBodyOnly And lNoBody Then
      Err.Raise 520, _
                "DrawTabThemeBackground", _
                "Error in function call, check parameters:   " & _
                vbCrLf & vbCrLf & "    lBodyOnly and lNoBody are both true.   " & _
                vbCrLf
   End If
    
   'The only reason you can cause this problem is the design of this function,
   'which in this case is a feature and not a bug. ;) It gives me the chance
   'to demonstrate Error Raising in user functions.
   '
   'I could have taken a little different aproach in function design or just
   'validate the other variables passed, and act accordingly.
   '
   'For example if TabTitle <> vbNullString, the developer wants to fake a
   'Tab Control and that *has* to have a Tab pane. In any other situation
   'I could have used the first True and set the conflicting variable to False.
   '
   'When the developer looks at the form at runtime, he'll notice the Tab isn't
   'what he expected it to be. He can now do two things, say the function sucks
   'and move on, or look at the way he's calling it... <g>
   '
   'Error raising can be usefull if your function isn't generating any errors
   'as far as the compiler's concern, but to you as developer and therefore the
   'enduser. But let's get on with it.
       
   If ThemeSysFont <> vbNullString Then
    
      On Error Resume Next
      Obj.Font.Name = ThemeSysFont                          'Or it looks real bad!... well,
      On Error GoTo 0                                       'to me that is of course... ;)
       
   End If
       
   GetClientRect Obj.hwnd, tR                               'Get the drawing area rectangle
       
   If Not TabTitle = vbNullString Then                       'Some calculating...
    
      tR.Top = 165 / Screen.TwipsPerPixelY                  'Top margin
      tR.Left = 135 / Screen.TwipsPerPixelX                 'Left margin
      tR.Right = tR.Right - (120 / Screen.TwipsPerPixelX)   'Right margin
      tR.Bottom = tR.Bottom - (650 / Screen.TwipsPerPixelY)  'Button margin below the Tab.
    
      tR2.Top = 150 / Screen.TwipsPerPixelY                 'Tab text.
      tR2.Left = 135 / Screen.TwipsPerPixelX
      tR2.Bottom = 435 / Screen.TwipsPerPixelY
      tR2.Right = (Obj.TextWidth(TabTitle) / Screen.TwipsPerPixelX) + 24
      tR.Top = tR.Top + (tR2.Bottom - tR2.Top) - 2           ' Make some space for header.
       
      strLength = (Obj.TextWidth(TabTitle) / Screen.TwipsPerPixelX)
                                                            'Get length of TabTitle.
   End If
       
   If IsThemed_(Obj.hwnd) Then                              'Check for theme presence
       
      Obj.Cls                                               'Clear Objects surface.
      Obj.AutoRedraw = True                                  'Make sure AutoRedraw = True
      Obj.BackColor = vbButtonFace                          'Should be default with a Tab
                                                            'Control.
      hTheme = OpenThemeData(Obj.hwnd, StrPtr("Tab"))       'Open with correct theme item
 
      If Not lBodyOnly Then                                 'They want the gradient...
       
          If TabTitle = vbNullString Then                    '...but not to fake a tab.
          
            tR.Top = tR.Top + 1                             'Zero doesn't paint the top and
            tR.Left = tR.Left + 1                           'left borders on a visible part
                                                            'of Obj.
         End If
    
         lR = DrawThemeBackground(hTheme, Obj.hDC, _
                                  TAB_PANE, _
                                  TIS_NORMAL, _
                                  tR, tR)                   'Draw the Tab Pane (No gradient
                                                            'background)
          
         If Not lNoBody Then
          
             
            InflateRect tR, -3, -3                          'Adjust the rectangle size, to
                                                             'Draw the Tab body (Gradient)
                                                            'inside the Tab Pane.
            lR = DrawThemeBackground(hTheme, Obj.hDC, _
                                     TAB_BODY, _
                                     TIS_NORMAL, _
                                     tR, tR)                'Draw Tab body (Gradient
         End If                                             'background)
                           
      Else
                                                                 
         If Not lNoBody Then
                   
            lR = DrawThemeBackground(hTheme, Obj.hDC, _
                                     TAB_BODY, _
                                     TIS_NORMAL, _
                                     tR, tR)                'Draw Tab body (Gradient
                                                            'background)
         End If
                                                       
      End If
 
      InflateRect tR2, 0, 1                                  'A little adjustment ...
 
      If Not TabTitle = vbNullString Then
       
         lR = DrawThemeBackground(hTheme, Obj.hDC, _
                                  TAB_TOPTABITEM, _
                                  TIBES_SELECTED, _
                                  tR2, tR2)                 'Draw Tab Header
                                            
         lR = DrawThemeBackground(hTheme, Obj.hDC, _
                                  TAB_TOPTABITEMRIGHTEDGE, _
                                  TTIRES_SELECTED, _
                                  tR2, tR2)                 'Draw Tab Header Right Edge
                                   
         lR = DrawThemeBackground(hTheme, Obj.hDC, _
                                  TAB_TOPTABITEMLEFTEDGE, _
                                  TILES_SELECTED, _
                                  tR2, tR2)                 'Draw Tab Header Left Edge
                                            
         tR2.Top = tR2.Top + 4                              'A little smuggling ...
                                                                     
         lR = DrawThemeText(hTheme, _
                            Obj.hDC, _
                            TAB_TOPTABITEM, _
                            TTIBES_SELECTED, _
                            StrPtr(TabTitle), _
                            -1, _
                            DT_CENTER Or DT_VCENTER, _
                            0, _
                             tR2)                            'Draw the text.
 
       
      End If
                                                       
      CloseThemeData hTheme                                 'Release Handle
      DrawTabThemeBackground = True                         'Success, return True.
       
      Exit Function
    
   Else                                                     'Draw legacy fake tab.
    
      GetClientRect Obj.hwnd, tR                               'Get the drawing area rectangle
 
      tR.Top = 120 / Screen.TwipsPerPixelY                  'Top margin
      tR.Left = 120 / Screen.TwipsPerPixelX                 'Left margin
      tR.Right = (Obj.Width / Screen.TwipsPerPixelX) - (215 / Screen.TwipsPerPixelX)   'Right margin
      tR.Bottom = tR.Bottom - (630 / Screen.TwipsPerPixelY)   'Button margin below the Tab.
    
      tR2.Top = 135 / Screen.TwipsPerPixelY                 'Tab text.
      tR2.Left = 120 / Screen.TwipsPerPixelX
      tR2.Bottom = 465 / Screen.TwipsPerPixelY
      tR2.Right = (Obj.TextWidth(TabTitle) / Screen.TwipsPerPixelX) + 25
      tR.Top = tR.Top + (tR2.Bottom - tR2.Top) '- 2          ' Make some space for header.
       
      DrawEdge Obj.hDC, tR, EDGE_RAISED, BF_RECT
       
      If Not TabTitle = vbNullString Then
       
         DrawEdge Obj.hDC, tR2, EDGE_RAISED, BF_RIGHT
          
         DrawEdge Obj.hDC, tR2, EDGE_RAISED, BF_LEFT
                                                 
         DrawEdge Obj.hDC, tR2, EDGE_RAISED, BF_TOP
          
         'Since whe're only drawing the borders, the legacy fake Tab is fully
          'Transparent. With the below function, I'm smuggling  a little again
         'by copying a small part just below the frame top edge and draw it
         'over the frame top edge where the caption will be drawn.
          
         lR = BitBlt(Obj.hDC, tR2.Left + 2, tR2.Bottom - 1, strLength + 15, tR2.Left + 3, _
                     Obj.hDC, tR2.Left + 2, tR2.Bottom + 1, vbSrcCopy)
                   
         tR2.Right = tR2.Right - 8
         tR2.Top = tR2.Top + 6
          
         DrawText Obj.hDC, TabTitle, Len(TabTitle), tR2, vbButtonText
          
      End If
          
      DrawTabThemeBackground = True
 
      Exit Function
    
   End If
    
ThemeError:
 
   DrawTabThemeBackground = False                           'Function failed...
 
   If ShowErrMsg Then
 
      If MsgBox("An Error occurred in Function DrawTabThemeBackground:    " & vbCrLf & vbCrLf & _
                "Return value" & vbTab & ": " & Str$(lR) & vbCrLf & _
                "Error number" & vbTab & ": " & Err.Number & vbCrLf & _
                "Error description" & vbTab & ": " & Err.Description & "   " & vbCrLf & _
                "Error Object" & vbTab & ": " & Obj.Name & vbCrLf & _
                "Error source" & vbTab & ": " & Err.Source & vbCrLf & vbCrLf & _
                "Would you like to try to continue executing this function?   ", _
                 vbExclamation + vbYesNo) = vbYes Then
       
         Resume Next
          
      Else
       
         Resume AllNotSoWell
       
      End If
        
   Else
    
      Resume AllNotSoWell
        
   End If
 
AllNotSoWell:
 
   Exit Function
 
End Function


Public Function IsThemed_(Optional hwnd As Long = 0, Optional ShowErrMsg As Boolean = False) As Boolean
 
On Error GoTo ThemeError                              'Catch errors, like calling a DLL                                                  'Catch errors...
                                                      'function and no  DLL in sight. (W2K ?)
   Dim hTheme As Long                                 'Declare variable for Theme Handle
    
   If IsThemeActive() Then                            'Aha, theming! Now try to get a handle.
    
      If hwnd = 0 Then                                'But first make sure we've got a valid
                                                      'hWnd passed, and if not get the
         hwnd = GetDesktopWindow                       'Desktop's
       
      End If
    
      hTheme = OpenThemeData(hwnd, StrPtr("Status"))  'Any pszClasslist item will do, I
                                                      'just picked "Status" at random.
      If (hTheme <> 0) Then                           'We've got a handle
    
         CloseThemeData hTheme                        'Release handle.
         IsThemed_ = True                              'Return Success.
          
         Exit Function                                'We don't want to bump into
                                                      'ThemeError. ;)
      Else
          
         IsThemed_ = False                            'Can't get a handle, so nothing is open.
          
         Exit Function                                'Let's split!
          
      End If
    
   Else
    
      IsThemed_ = False                                'No theming!
       
      Exit Function                                   'Let's split here too!
    
   End If
 
ThemeError:
 
   IsThemed_ = False                                  'Don't forget to set flag to false.
 
   If ShowErrMsg Then                                 '... display MessageBox with Error
    
      MsgBox "An Error occurred in Function IsThemed_: " & vbCrLf & vbCrLf & _
             "Error number" & vbTab & ": " & Err.Number & vbCrLf & _
             "Error description" & vbTab & ": " & Err.Description & "   " & vbCrLf & _
             "Error source" & vbTab & ": " & Err.Source & vbCrLf & vbCrLf & _
             "Code execution has stopped for this call.   ", vbExclamation
 
   End If
 
   Resume AllNotSoWell
 
AllNotSoWell:
 
   Exit Function
 
End Function
 
'See WhatIsThemeFont just below.
 
Public Function ThemeSysFont() As String
 
   Dim lHwnd As Long
   Dim lHdc As Long
   Dim lKind As Long
   Dim lState As Long
 
   lHwnd = GetDesktopWindow
   lHdc = GetDC(lHwnd)
   lKind = 4     '4 = PB_GROUPBOX
   lState = 1    '1 = PBS_NORMAL
 
   ThemeSysFont = WhatIsThemeFont("Button", lHwnd, lHdc, lKind, lState)
     
   ReleaseDC lHwnd, lHdc
 
End Function
 
'This function needs more attention. Will do that later.
'
'WhatIsThemeFont will return just a string containing the
'font name, not the font object.
 
Public Function WhatIsThemeFont(pszClassListItem As String, lHwnd As Long, lHdc As Long, iPartId As Long, iState As Long) As String
 
   On Error Resume Next
 
   Dim tLogFont As FONTSLOG
   Dim hTheme  As Long
 
   If IsThemed_(lHwnd) Then
 
      hTheme = OpenThemeData(lHwnd, StrPtr(pszClassListItem))
 
      If hTheme <> 0 Then
 
         GetThemeFont hTheme, lHdc, iPartId, iState, TMT_FONT, tLogFont
 
            If tLogFont.flfFaceName <> "" Then
 
               WhatIsThemeFont = tLogFont.flfFaceName
 
            Else
 
               WhatIsThemeFont = "MS Sans Serif"       'Just to be safe.
  
            End If
 
         CloseThemeData hTheme
 
      Else
 
         WhatIsThemeFont = "MS Sans Serif"
 
            'Not good if you get here, so show a message.
 
            MsgBox "An Error occured retrieving a theme handle from OpenThemeData():   " & vbCrLf & vbCrLf & _
                   " - Function" & vbTab & ": WhatIsThemeFont   " & vbCrLf & _
                   " - Module  " & vbTab & ": DrawTabBckgrnd.bas   ", vbCritical
 
      End If
 
   Else
  
      WhatIsThemeFont = "MS Sans Serif"               'Default on any none themed OS, this is
                                                      'the dirty way, I know. :)
   End If
 
   On Error GoTo 0                                    'Reset normal error trapping
 
End Function

' trova la versione di Windows
Public Function GetWindowsVersion() As Long
    Dim OSInfo As OSVERSIONINFO2
    Dim RetValue As Long
    OSInfo.dwOSVersionInfoSize = 148
    OSInfo.szCSDVersion = Space$(128)
    RetValue = GetVersionEx2(OSInfo)
    With OSInfo
        ' BuildNumber = .dwBuildNumber & & 0xFFFF
        Select Case .dwPlatformID
            Case VER_PLATFORM_WIN32_WINDOWS
                If .dwMinorVersion = 0 Then
                    GetWindowsVersion = WINDOWS_95
                ElseIf .dwMinorVersion = 10 Then
                    GetWindowsVersion = WINDOWS_98
                End If
            Case VER_PLATFORM_WIN32_NT
                If .dwMajorVersion = 3 Then
                    GetWindowsVersion = WINDOWS_NT_3_51
                ElseIf .dwMajorVersion = 4 Then
                    GetWindowsVersion = WINDOWS_NT_4
                ElseIf .dwMajorVersion = 5 Then
                    If .dwMinorVersion = 0 Then
                      GetWindowsVersion = WINDOWS_2000
                    ElseIf .dwMinorVersion = 1 Then
                      GetWindowsVersion = WINDOWS_XP ' WindowsXP
                    End If
                End If
            Case Else
                GetWindowsVersion = UNKNOWN_OS
        End Select
    End With
End Function

Public Sub ChangeButtonStyle(ByRef cmd As CommandButton, ByVal Parent As Object)
'/ visualizza un CommandButton come un controllo Frame
'/ Inoltre per evitare che lo sfondo del testo
'/ ed imposta il colore di sfondo
    On Error Resume Next
    
    '/ cambio lo stile
    SendMessage cmd.hwnd, BM_SETSTYLE, BS_GROUPBOX, 0
    
    '/ modifico il colore di sfondo per simulare la trasparenza
    '/ dello sfondo del testo
    If WinVersion = WINDOWS_XP Then
        '/ dato che il contenitore ha uno sfondo gradiente, cerco
        '/ di usare il colore che sta sotto al CommandButton
        cmd.BackColor = cmd.Container.Point(cmd.Left, cmd.Top)
    Else
        '/ in questo esempio, se non ?Windows XP non uso il
        '/ gradiente, ma il colore normale del contenitore
        cmd.BackColor = cmd.Container.BackColor
    End If
    
    '/ Nota: disattivare il TabStop, perch?quando perde il focus
    '/ usando il tastp TAB si modifica lo stile dei CommandButton
    '/ che diventano dei CheckBox. (Chiss?perch? poi...)
    '/ Comunque, in fin dei conti, il focus non serve!
    cmd.TabStop = False
    
End Sub

Public Sub DrawGradient( _
    ByVal hDC As Long, _
    ByRef rct As RECT, _
    ByVal lEndColour As Long, _
    ByVal lStartColour As Long, _
    Optional ByVal bVertical As Boolean = False)

    Dim lStep As Long
    Dim lPos As Long, lSize As Long
    Dim bRGB(1 To 3) As Integer
    Dim bRGBStart(1 To 3) As Integer
    Dim dR(1 To 3) As Double
    Dim dPos As Double, D As Double
    Dim hBr As Long
    Dim tR As RECT
   
  DoEvents
  
  LSet tR = rct
  If bVertical Then
    lSize = (tR.Bottom - tR.Top)
  Else
    lSize = (tR.Right - tR.Left)
  End If
  lStep = lSize \ 255
  If (lStep < 3) Then
      lStep = 3
  End If
       
  bRGB(1) = lStartColour And &HFF&
  bRGB(2) = (lStartColour And &HFF00&) \ &H100&
  bRGB(3) = (lStartColour And &HFF0000) \ &H10000
  bRGBStart(1) = bRGB(1): bRGBStart(2) = bRGB(2): bRGBStart(3) = bRGB(3)
  dR(1) = (lEndColour And &HFF&) - bRGB(1)
  dR(2) = ((lEndColour And &HFF00&) \ &H100&) - bRGB(2)
  dR(3) = ((lEndColour And &HFF0000) \ &H10000) - bRGB(3)
        
  For lPos = lSize To 0 Step -lStep
     If bVertical Then
        tR.Top = tR.Bottom - lStep
     Else
        tR.Left = tR.Right - lStep
     End If
     If tR.Top < rct.Top Then
        tR.Top = rct.Top
     End If
     If tR.Left < rct.Left Then
        tR.Left = rct.Left
     End If
     
     hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
     FillRect hDC, tR, hBr
     DeleteObject hBr
           
     ' Aggiusto in base all'orientamento:
     dPos = ((lSize - lPos) / lSize)
     
     If bVertical Then
        tR.Bottom = tR.Top
        bRGB(1) = bRGBStart(1) + dR(1) * dPos
        bRGB(2) = bRGBStart(2) + dR(2) * dPos
        bRGB(3) = bRGBStart(3) + dR(3) * dPos
     Else
        tR.Right = tR.Left
        bRGB(1) = bRGBStart(1) + dR(1) * dPos
        bRGB(2) = bRGBStart(2) + dR(2) * dPos
        bRGB(3) = bRGBStart(3) + dR(3) * dPos
     End If
     
  Next lPos

End Sub

Public Sub MakeTransparentControl(frm As Form)
    Dim lColor As Long, ctl As Control

    '/ Non tutti i controlli hanno le stesse propriet?(BackColor,
    '/ BackStyle, ecc.) quindi gestisco l'errore io. In questo modo
    '/ posso aggiungere qualsiasi controllo senza problema.
    '/ Diversamente occorre testare il tipo di controllo con TypeOf
    On Error Resume Next
    
    For Each ctl In frm.Controls
        If TypeOf ctl Is Label Then
'            / mi assicuro che i Label siano tutti trasparenti
            ctl.BackStyle = vbTransparent
        End If
        If Not IsThemed_(frm.hwnd) Then
            If TypeOf ctl Is PictureBox Then
                ctl.BackColor = frm.BackColor
            End If
        End If
        If TypeOf ctl Is CheckBox Or TypeOf ctl Is OptionButton Then
            lColor = ctl.Container.Point(ctl.Left, ctl.Top)
            If lColor > 0 Then ctl.BackColor = lColor
        End If
        
        '/ cambio il Font a seconda del sistema operativo
        If WinVersion = WINDOWS_XP Then
            ctl.Font.Name = "Tahoma"
        Else
            ctl.Font.Name = "MS Sans Serif"
        End If
        If TypeOf ctl Is CommandButton Then
            If WinVersion = WINDOWS_XP Then
                ctl.BackColor = ctl.Container.Point(ctl.Left, ctl.Top)
            Else
                ctl.BackColor = ctl.Container.BackColor
            End If
        End If
    Next
    On Error GoTo 0

End Sub

