vbAccelerator - Contents of code file: frmChild.frm

VERSION 5.00
Object = "{72D18DD4-0DA7-11D2-8E21-00B404C10000}#2.1#0"; "ODCboLst6.ocx"
Object = "*\AODCboLst6.vbp"
Begin VB.Form frmChild 
   Caption         =   "Test Child Form"
   ClientHeight    =   3975
   ClientLeft      =   4515
   ClientTop       =   3720
   ClientWidth     =   6045
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3975
   ScaleWidth      =   6045
   Begin VB.CommandButton cmdSetFont 
      Caption         =   "Set &Font..."
      Height          =   375
      Left            =   120
      TabIndex        =   7
      Top             =   3540
      Width           =   1335
   End
   Begin VB.ListBox lstVB 
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1800
      IntegralHeight  =   0   'False
      Left            =   3060
      TabIndex        =   5
      Top             =   1080
      Width           =   2835
   End
   Begin ODCboLst6.OwnerDrawComboList lstODCBO 
      Height          =   1815
      Left            =   120
      TabIndex        =   4
      Top             =   1080
      Width           =   2835
      _ExtentX        =   5001
      _ExtentY        =   3201
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   -2147483630
      Style           =   4
      FullRowSelect   =   -1  'True
      MaxLength       =   0
   End
   Begin ODCboLst6.OwnerDrawComboList cboTest 
      Height          =   315
      Left            =   120
      TabIndex        =   1
      Top             =   3060
      Width           =   2835
      _ExtentX        =   5001
      _ExtentY        =   556
      ExtendedUI      =   -1  'True
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   -2147483630
      ClientDraw      =   5
      Style           =   0
      AutoComplete    =   -1  'True
      AutomCompleteListItemsOnly=   -1  'True
   End
   Begin VB.ComboBox cboReal 
      BeginProperty Font 
         Name            =   "Tahoma"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   3060
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   360
      Width           =   2835
   End
   Begin ODCboLst6.OwnerDrawComboList cboCopy 
      Height          =   405
      Left            =   120
      TabIndex        =   6
      Top             =   360
      Width           =   2835
      _ExtentX        =   5001
      _ExtentY        =   635
      ExtendedUI      =   -1  'True
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Tahoma"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   -2147483630
      MaxLength       =   0
   End
   Begin VB.Label lblInfo 
      Caption         =   "VB Controls:"
      Height          =   195
      Index           =   1
      Left            =   3060
      TabIndex        =   3
      Top             =   120
      Width           =   2775
   End
   Begin VB.Label lblInfo 
      Caption         =   "Owner Draw Combo List:"
      Height          =   195
      Index           =   0
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   2775
   End
End
Attribute VB_Name = "frmChild"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Type TCHOOSEFONT
    lStructSize As Long         ' Filled with UDT size
    hWndOwner As Long           ' Caller's window handle
    hdc As Long                 ' Printer DC/IC or NULL
    lpLogFont As Long           ' Pointer to LOGFONT
    iPointSize As Long          ' 10 * size in points of font
    flags As Long               ' Type flags
    rgbColors As Long           ' Returned text color
    lCustData As Long           ' Data passed to hook function
    lpfnHook As Long            ' Pointer to hook function
    lpTemplateName As Long      ' Custom template name
    hInstance As Long           ' Instance handle for template
    lpszStyle As String         ' Return style field
    nFontType As Integer        ' Font type bits
    iAlign As Integer           ' Filler
    nSizeMin As Long            ' Minimum point size allowed
    nSizeMax As Long            ' Maximum point size allowed
End Type
Private Declare Function ChooseFont Lib "COMDLG32" _
    Alias "ChooseFontA" (chfont As TCHOOSEFONT) As Long
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(LF_FACESIZE) As Byte
End Type

Public Enum EChooseFont
    CF_ScreenFonts = &H1
    CF_PrinterFonts = &H2
    CF_BOTH = &H3
    CF_FontShowHelp = &H4
    CF_UseStyle = &H80
    CF_EFFECTS = &H100
    CF_AnsiOnly = &H400
    CF_NoVectorFonts = &H800
    CF_NoOemFonts = CF_NoVectorFonts
    CF_NoSimulations = &H1000
    CF_LimitSize = &H2000
    CF_FixedPitchOnly = &H4000
    CF_WYSIWYG = &H8000  ' Must also have ScreenFonts And PrinterFonts
    CF_ForceFontExist = &H10000
    CF_ScalableOnly = &H20000
    CF_TTOnly = &H40000
    CF_NoFaceSel = &H80000
    CF_NoStyleSel = &H100000
    CF_NoSizeSel = &H200000
    ' Win95 only
    CF_SelectScript = &H400000
    CF_NoScriptSel = &H800000
    CF_NoVertFonts = &H1000000

    CF_InitToLogFontStruct = &H40
    CF_Apply = &H200
    CF_EnableHook = &H8
    CF_EnableTemplate = &H10
    CF_EnableTemplateHandle = &H20
    CF_FontNotSupported = &H238
End Enum

' These are extra nFontType bits that are added to what is returned to the
' EnumFonts callback routine

Public Enum EFontType
    Simulated_FontType = &H8000
    Printer_FontType = &H4000
    Screen_FontType = &H2000
    Bold_FontType = &H100
    Italic_FontType = &H200
    Regular_FontType = &H400
End Enum
Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)

' ChooseFont wrapper
Private Function VBChooseFont(CurFont As Font, _
                      Optional PrinterDC As Long = -1, _
                      Optional Owner As Long = -1, _
                      Optional Color As Long = vbBlack, _
                      Optional MinSize As Long = 0, _
                      Optional MaxSize As Long = 0, _
                      Optional flags As Long = 0 _
                    ) As Boolean
Dim lR As Long

   ' Unwanted Flags bits
   Const CF_FontNotSupported = CF_Apply Or CF_EnableHook Or CF_EnableTemplate
   
   ' Flags can get reference variable or constant with bit flags
   ' PrinterDC can take printer DC
   If PrinterDC = -1 Then
       PrinterDC = 0
       If flags And CF_PrinterFonts Then PrinterDC = Printer.hdc
   Else
       flags = flags Or CF_PrinterFonts
   End If
   ' Must have some fonts
   If (flags And CF_PrinterFonts) = 0 Then flags = flags Or CF_ScreenFonts
   ' Color can take initial color, receive chosen color
   If Color <> vbBlack Then flags = flags Or CF_EFFECTS
   ' MinSize can be minimum size accepted
   If MinSize Then flags = flags Or CF_LimitSize
   ' MaxSize can be maximum size accepted
   If MaxSize Then flags = flags Or CF_LimitSize
   
   ' Put in required internal flags and remove unsupported
   flags = (flags Or CF_InitToLogFontStruct) And Not CF_FontNotSupported
   
   ' Initialize LOGFONT variable
   Dim fnt As LOGFONT
   Const PointsPerTwip = 1440 / 72
   fnt.lfHeight = -(CurFont.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
   fnt.lfWeight = CurFont.Weight
   fnt.lfItalic = CurFont.Italic
   fnt.lfUnderline = CurFont.Underline
   fnt.lfStrikeOut = CurFont.Strikethrough
   ' Other fields zero
   StrToBytes fnt.lfFaceName, CurFont.Name
   
   ' Initialize TCHOOSEFONT variable
   Dim cf As TCHOOSEFONT
   cf.lStructSize = Len(cf)
   If Owner <> -1 Then cf.hWndOwner = Owner
   cf.hdc = PrinterDC
   cf.lpLogFont = VarPtr(fnt)
   cf.iPointSize = CurFont.Size * 10
   cf.flags = flags
   cf.rgbColors = Color
   cf.nSizeMin = MinSize
   cf.nSizeMax = MaxSize
       
   ' All other fields zero
   lR = ChooseFont(cf)
   Select Case lR
   Case 1
       ' Success
       VBChooseFont = True
       flags = cf.flags
       Color = cf.rgbColors
       CurFont.Bold = cf.nFontType And Bold_FontType
       'CurFont.Italic = cf.nFontType And Italic_FontType
       CurFont.Italic = fnt.lfItalic
       CurFont.Strikethrough = fnt.lfStrikeOut
       CurFont.Underline = fnt.lfUnderline
       CurFont.Weight = fnt.lfWeight
       CurFont.Size = cf.iPointSize / 10
       CurFont.Name = BytesToStr(fnt.lfFaceName)
   Case 0
       ' Cancelled
       VBChooseFont = False
   Case Else
       ' Extended error
       VBChooseFont = False
   End Select
        
End Function
Private Function IsArrayEmpty(va As Variant) As Boolean
    Dim v As Variant
    On Error Resume Next
    v = va(LBound(va))
    IsArrayEmpty = (Err <> 0)
End Function

Private Sub StrToBytes(ab() As Byte, s As String)
    If IsArrayEmpty(ab) Then
        ' Assign to empty array
        ab = StrConv(s, vbFromUnicode)
    Else
        Dim cab As Long
        ' Copy to existing array, padding or truncating if necessary
        cab = UBound(ab) - LBound(ab) + 1
        If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
        'If UnicodeTypeLib Then
        '    Dim st As String
        '    st = StrConv(s, vbFromUnicode)
        '    CopyMemoryStr ab(LBound(ab)), st, cab
        'Else
            CopyMemoryStr ab(LBound(ab)), s, cab
        'End If
    End If
End Sub
Private Function BytesToStr(ab() As Byte) As String
    BytesToStr = StrConv(ab, vbUnicode)
End Function


Private Sub cboReal_KeyPress(KeyAscii As Integer)
If (KeyAscii >= Asc("a") And KeyAscii <= Asc("b")) Then
   KeyAscii = Asc(UCase$(Chr$(KeyAscii)))
End If
End Sub


Private Sub cmdSetFont_Click()
Dim sFnt As StdFont
   Set sFnt = cboReal.Font
   If (VBChooseFont(sFnt, , Me.hwnd, , 8, 36)) Then
      Set cboReal.Font = sFnt
      Set cboCopy.Font = sFnt
      cboCopy.DropDownWidth = (cboCopy.Width * 2) \ Screen.TwipsPerPixelX
      Set lstVB.Font = sFnt
      Set lstODCBO.Font = sFnt
   End If
End Sub

Private Sub Form_Load()
Dim i As Integer, l As Long
   AddItems lstVB
   AddItems lstODCBO
   AddItems cboReal
   AddItems cboCopy
End Sub
Private Sub AddItems(ctlThis As Control)
Dim l As Long
   If TypeOf ctlThis Is OwnerDrawComboList Then
      For l = 1 To 100
        ctlThis.AddItemAndData "Item:" & l & " & for testing ampersand", , (l
         Mod 3) * 8
      Next l
   Else
      For l = 1 To 100
        ctlThis.AddItem "Item:" & l & " & for testing ampersand"
      Next l
   End If
   ctlThis.ListIndex = 0
End Sub