1. Как сделать чтобы при вызове диалога показывался используемый шрифт (и сопутствующая информация ( размер , наклон ... ) ) для данного контрола (в котором хотим изменить шрифт )
2. Иногда при неоднократном изменении шрифтов прога падает - наверное какая-то ошибка в самом коде, подскажите плз где...
Юзаю этот код
- Код: Выделить всё
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
Private Type ChooseFont
lStructSize As Long
hwndOwner As Long ' caller's window handle
hdc As Long ' printer DC/IC or NULL
lpLogFont As Long ' LOGFONT ' ptr. to a LOGFONT struct
iPointSize As Long ' 10 * size in points of selected font
flags As Long ' enum. type flags
rgbColors As Long ' returned text color
lCustData As Long ' data passed to hook fn.
lpfnHook As Long ' ptr. to hook function
lpTemplateName As String ' custom template name
hInstance As Long ' instance handle of.EXE that
lpszStyle As String ' return the style field here
nFontType As Integer ' same value reported to the EnumFonts
MISSING_ALIGNMENT As Integer
nSizeMin As Long ' minimum pt size allowed &
nSizeMax As Long ' max pt size allowed if
End Type
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Const CF_SCREENFONTS = &H1
Private Const CF_PRINTERFONTS = &H2
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_SHOWHELP = &H4&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_USESTYLE = &H80&
Private Const CF_EFFECTS = &H100&
Private Const CF_APPLY = &H200&
Private Const CF_ANSIONLY = &H400&
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_WYSIWYG = &H8000 ' must also have CF_SCREENFONTS CF_PRINTERFONTS
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_TTONLY = &H40000
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOSIZESEL = &H200000
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOVERTFONTS = &H1000000
Private Function CString(aStr As String) As String
CString = ""
Dim k As Long
k = InStr(aStr, Chr$(0))
If k Then
CString = Left$(aStr, k - 1)
End If
End Function
Private Sub Command1_Click()
Dim CF As ChooseFont, hMem As Long, LF As LOGFONT, aFontName As String
hMem = GlobalAlloc(GPTR, Len(LF))
CF.hInstance = App.hInstance
CF.hwndOwner = hWnd
CF.lpLogFont = hMem
CF.lStructSize = Len(CF)
CF.flags = CF_BOTH
If ChooseFont(CF) Then
CopyMemory LF, ByVal hMem, Len(LF)
aFontName = Space$(LF_FACESIZE)
CopyMemory ByVal aFontName, LF.lfFaceName(0), LF_FACESIZE
With Label1.Font
.Name = CString(aFontName)
.Bold = LF.lfWeight
.Italic = LF.lfItalic
.Size = CF.iPointSize / 10
.Underline = LF.lfUnderline
.Charset = LF.lfCharSet
.Strikethrough = LF.lfStrikeOut
End With
End If
GlobalFree hMem
End Sub
