lStyle = lStyle Or LVS_EX_FULLROWSELECT Or LVS_EX_DOUBLEBUFFER

SetWindowTheme ListView1.hwnd, StrPtr("explorer"), 0

 Public Function NewListWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'для событий listview
    If (Msg = &HF) Then 'WM_PAINT
        Form1.RedrawHeaders
    end if
...
Public Sub RedrawHeaders()
'    'перерисовка,ибо сам не удосуживается это сделать
    Dim pvHeaderhWnd As Long
        pvHeaderhWnd = SendMessageLong(ListView1.hwnd, LVM_GETHEADER, 0, 0)
        Call RedrawWindow(pvHeaderhWnd, ByVal 0&, ByVal 0&, RDW_INVALIDATE Or RDW_FRAME Or RDW_UPDATENOW)
...

Public Sub RedrawHeaders()
'    'перерисовка,ибо сам не удосуживается это сделать
    Dim pvHeaderhWnd As Long
        pvHeaderhWnd = SendMessageLong(ListView1.hwnd, LVM_GETHEADER, 0, 0)
        Call RedrawWindow(pvHeaderhWnd, ByVal 0&, ByVal 0&, RDW_INVALIDATE Or RDW_FRAME Or RDW_UPDATENOW)

    Dim lvFormat As LV_COLUMN
        With lvFormat
            .mask = LVCF_FMT Or LVCF_IMAGE
            .fmt = LVCFMT_IMAGE 'Or LVCFMT_BITMAP_ON_RIGHT   '
            .iImage = 1
        End With
    'Call SendMessage(ListView1.hwnd, LVM_SETCOLUMN, 0, lvFormat)
    Call SendMessage(ListView1.hwnd, LVM_SETCOLUMN, 1, lvFormat)
    Call SendMessage(ListView1.hwnd, LVM_SETCOLUMN, 2, lvFormat)
End Sub

Public Function NewListHeaderWindowProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 'Private Const WM_MOUSEUP = &H200
 'для событий listview Header
     If (Msg = &H200) Then 'WM_MOUSEUP 
         Form1.RedrawHeaders
    End If
    NewListHeaderWindowProc = CallWindowProc( _
        OldListHeaderWindowProc, hwnd, Msg, wParam, _
        lParam)
End Function

Private Declare Function DeactivateWindowTheme Lib "uxtheme" _
    Alias "SetWindowTheme" ( _
     ByVal hwnd As Long, _
     Optional ByRef pszSubAppName As String = " ", _
     Optional ByRef pszSubIdList As String = " ") As Long

Private Function HD_Height(hFont As Long, HD_hWnd As Long)
Dim Retv As Long
Dim tHDL As HDLAYOUT
Dim rc As RECT
Dim pwpos As WINDOWPOS
Retv = SendMessage(HD_hWnd, WM_SETFONT, hFont, True)
If Retv Then
    tHDL.lprc = VarPtr(rc)
    tHDL.lpwpos = VarPtr(pwpos)

    Call SendMessage(HD_hWnd, HDM_LAYOUT,  0 , tHDL)
    Height = rc.top
End If
Private Sub SetHeight() 'в Load например
    Dim fnt As IFont
    Dim pvHeaderhWnd As Long
    Set fnt = Me.Font
    fnt.Size =  10 
    pvHeaderhWnd = SendMessageLong(ListView1.hwnd, LVM_GETHEADER,  0 ,  0 )
    HD_Height fnt.hFont, pvHeaderhWnd
...

Мона создать два шрифта.
Одним изменять размер, другой использовать для создания образа в контексте
и с помощью BitBlt скопировать в итем хидера.
Все. Тема закрыта.
Всем спасибо! 

Private Function IdealHeaderHeight(m_hWnd As Long) As Long
Dim tHDL As HDLAYOUT
Dim rc As RECT
Dim pwpos As WINDOWPOS
Dim lR As Long
Dim lHeight As Long
Dim cx As Long
Dim cy As Long
   
   tHDL.lprc = VarPtr(rc)
   tHDL.lpwpos = VarPtr(pwpos)
   
   lR = SendMessage(m_hWnd, HDM_LAYOUT,  0 , tHDL)
   lHeight = pwpos.cy
   'MsgBox lHeight
   'ImageList_GetIconSize m_hIml, cx, cy
   cx =  16 
   cy =  16 
   If (lHeight < cy +  4 ) Then
      lHeight = cy +  4 
   End If
   IdealHeaderHeight = lHeight
'//   rc.bottom = rc.top + lHeight
'//   SetWindowPos m_hWnd, 0, rc.left, rc.top, rc.right - rc.left, rc.bottom - rc.top, 1
'//   'MoveWindow m_hWnd, rc.left, rc.top, rc.right - rc.left, rc.bottom - rc.top, 1
'//   InvalidateRect m_hWnd, rc, 0
'//   UpdateWindow m_hWnd
End Function

  Call SendMessageLong(pvHeaderhWnd, HDM_SETBITMAPMARGIN, <width>,  0 ) 'HDM_SETBITMAPMARGIN

  Call SendMessageLong(pvHeaderhWnd, HDM_SETBITMAPMARGIN, <width>,  0 ) 'HDM_SETBITMAPMARGIN

  Call SendMessageLong(pvHeaderhWnd, HDM_SETBITMAPMARGIN,  0 ,  0 )

    If IsIDEApp Then
        m_hImlHD = ImageList_Create( 26 ,  16 , ILC_MASK Or ILC_COLOR32,  1 ,  0 )
        ImageList_AddMasked m_hImlHD, LoadResPicture( 201 , vbResBitmap), vbBlue
        ImageList_AddMasked m_hImlHD, LoadResPicture( 202 , vbResBitmap), vbBlue
        ImageList_AddMasked m_hImlHD, LoadResPicture( 203 , vbResBitmap), vbBlue
    Else
        m_hImlHD = ImageList_Create( 26 ,  16 , ILC_MASK Or ILC_COLOR32,  3 ,  0 )
        lngIcon = LoadImage(App.hInstance, MAKEINTRESOURCE( 201 ), IMAGE_ICON,  26 ,  16 , LR_DEFAULTCOLOR)
        ImageList_ReplaceIcon m_hImlHD, - 1 , lngIcon
        lngIcon = LoadImage(App.hInstance, MAKEINTRESOURCE( 202 ), IMAGE_ICON,  26 ,  16 , LR_DEFAULTCOLOR)
        ImageList_ReplaceIcon m_hImlHD, - 1 , lngIcon
        lngIcon = LoadImage(App.hInstance, MAKEINTRESOURCE( 203 ), IMAGE_ICON,  26 ,  16 , LR_DEFAULTCOLOR)
        ImageList_ReplaceIcon m_hImlHD, - 1 , lngIcon
    End If

Private Type WINDOWPOS
    hwnd As Long
    hWndInsertAfter As Long
    x As Long
    y As Long
    cx As Long
    cy As Long
    Flags As Long
End Type

Private Type HDLAYOUT
  prc As RECT
  pwpos As WINDOWPOS
End Type
'Private Type HDLAYOUT
'  prc As Long
'  pwpos As Long
'End Type

Public Function NewListHeadWindowProc( _
 ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  'для событий listview1 (header)
  Dim Layout As HDLAYOUT
  Dim wPos As WINDOWPOS

  
  If Msg = HDM_LAYOUT Then
    Debug.Print "HDM_LAYOUT"
    MoveMemory ByVal VarPtr(Layout), ByVal lParam, LenB(Layout)
    'MoveMemory wPos, Layout.pwpos, LenB(wPos)
'    Debug.Print Layout.prc & " / " & Layout.pwpos
'    MoveMemory wPos, ByVal Layout.pwpos, LenB(wPos)
    Debug.Print Layout.pwpos.cy
'    Dim the_cy As Long
'    MoveMemory the_cy, ByVal Layout.pwpos.cy, 4
'    Debug.Print the_cy
  End If

typedef struct _HD_LAYOUT {
  RECT      *prc;
  WINDOWPOS *pwpos;
} HDLAYOUT, *LPHDLAYOUT;

Private Type WINDOWPOS
    hwnd As Long
    hWndInsertAfter As Long
    x As Long
    y As Long
    cx As Long
    cy As Long
    Flags As Long
End Type

Private Type HD_LAYOUT
  prc As RECT
  pwpos As WINDOWPOS
End Type

Public Function NewListHeadWindowProc( _
 ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim tHDL As HD_LAYOUT

  If Msg = HDM_LAYOUT Then
    Debug.Print "HDM_LAYOUT"
    MoveMemory tHDL, ByVal lParam, LenB(tHDL)
    Debug.Print tHDL.pwpos.cy
...чего-то там меняем наверно tHDL.pwpos.cy
    'обратка
    MoveMemory ByVal lParam, tHDL, LenB(tHDL)
...

Private Sub Command1_Click()
  'MsgBox hwndH
  Dim tHDL As HD_LAYOUT
  Dim rc As RECT
  Dim pwpos As WINDOWPOS

  tHDL.prc = VarPtr(rc)
  tHDL.pwpos = VarPtr(pwpos)

  SendMessage hwndH, HDM_LAYOUT, 0, tHDL
  MsgBox pwpos.cy
...

Public fnt_LV As IFont 'родной шрифт Listview, которым пишем в заголовках headers через CustomDraw

Private Sub Form_Load()
  Set fnt_LV = Form1.ListView1.Font
...

  Dim fntHD As IFont
  Set fntHD = LabelHDFont.Font
  SendMessage hwndH, WM_SETFONT, fntHD.hFont, ByVal 0
  Set fntHD = Nothing

'для событий ListView1
Public Function NewListView1WindowProc _
  (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 ...
  Select Case Msg
   Case WM_NOTIFY:
     MoveMemory uNMHDR, ByVal lParam, Len(uNMHDR)
     Select Case uNMHDR.code
       Case NM_CUSTOMDRAW
         'Debug.Print "NM_CUSTOMDRAW"
         Static lvcd As NMCUSTOMDRAW
         MoveMemory lvcd, ByVal lParam, Len(lvcd)   ' every structs' member is a Long
         Select Case lvcd.dwDrawStage
           ' ====================================================
           Case CDDS_PREPAINT
             ' Tell the listview we want CDDS_ITEMPREPAINT for each item
             NewListView1WindowProc = CDRF_NOTIFYITEMDRAW
             Exit Function
             ' ====================================================
           Case CDDS_ITEMPREPAINT
             'Debug.Print lvcd.dwItemSpec
             DrawListViewHeader lvcd.hdc, lvcd.hdr.hwndFrom
             NewListView1WindowProc = CDRF_NEWFONT
             Exit Function
           Case Else
         End Select
       Case Else
     End Select


Public Sub DrawListViewHeader(the_hdc As Long, the_hwnd As Long)
  Dim rc As RECT
  Dim tPt As POINTAPI
  Dim hbmDstOld As Long
  
  SetBkMode the_hdc, TRANSPARENT
  SetTextColor the_hdc, vbWhite
  SetBkColor the_hdc, CLR_NONE
  
  hbmDstOld = SelectObject(the_hdc, hbshBackDigits)
  GetWindowRect the_hwnd, rc
  tPt.x = rc.Left
  tPt.y = rc.Top
  MapWindowPoints 0, Form1.PictureDigits.hwnd, tPt, 2
  rc.Left = tPt.x
  rc.Top = tPt.y
  SetBrushOrgEx the_hdc, -rc.Left, -rc.Top, tPt

  Dim rRB As RECT
  GetClientRect the_hwnd, rRB

  PatBlt the_hdc, 0, 0, (rRB.Right - rRB.Left), (rRB.Bottom - rRB.Top), PATCOPY
  'на XP CustomDraw текст не выравнивается по центру по вертикали, иконку тоже смещаем вверх
  'на >=Vista текст автовыравнивается по центру по вертикали, иконку тоже рисуем по центру
  If Form1.ListView1.ColumnHeaders(1).Tag = 1 Then
    DrawIconEx the_hdc, 6, IIf(IsWinVista, (rRB.Bottom - rRB.Top - 12) / 2, 3), lngIconAscending, 12, 12, 0, 0, DI_NORMAL
  Else
    DrawIconEx the_hdc, 6, IIf(IsWinVista, (rRB.Bottom - rRB.Top - 12) / 2, 3), lngIconDescending, 12, 12, 0, 0, DI_NORMAL
  End If

  SelectObject the_hdc, hbmDstOld
  
  SelectObject the_hdc, fnt_LV.hFont
  'SetTextAlign -не помогает на XP, а на >=Vista текст выравнивается автоматом
  'SetTextAlign the_hdc, TA_RTLREADING 'TA_LEFT 'Or TA_CENTER
  
End Sub