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
|
|