Access ASP SQL Server VBA NET - Форумы по проектированию

LEADERSOFT.ru Разработка на заказ программ и сайтов

Форумы по информационным технологиям

Начало

Forums

Регистрация | Вход

Форумы

Поиск

Список форумов

Программирование

Microsoft Access. Файлы mdb и accdb

Тема: Выбор шри...

Тема: Выбор шрифта для отчета

15.06.2007 21:04:18

Vladimir1

16 сообщения

Тема: Выбор шрифта для отчета

Кто знает, как программой VBA определить наличие шрифтов, установленных на компьютере? Помогите, пожалуйста!

P.S. Использование шрифтов
Автор: Vladimir от 01.07.2003 6:35:29 Источник ...

15.06.2007 21:04:18

All

4316 сообщения

RE: Выбор шрифта для отчета

Прочитать каталог "Windows\Fonts" :)

P.S. Использование шрифтов
Автор: Николай от 0:00:00 Источник ...

15.06.2007 21:04:18

Vladimir1

16 сообщения

RE: Выбор шрифта для отчета

Спасибо, Николай! Это я полагаю использованием объекта Filesearch? А как прочитать название шрифта? Я понимаю, что впрямую я смогу прочитать только имя файла. А как добраться до название шрифта Property? М.б. есть примерчик? Еще раз спасибо!

P.S. Использование шрифтов
Автор: Vladimir от 01.07.2003 14:28:42 Источник ...

15.06.2007 21:04:18

Вадим4

2 сообщения

RE: Выбор шрифта для отчета

Может это и поможет.

Enumerating System Fonts
Note: In order to test the code in this article, you will need the AddressOf code as well.
Another use of AddressOf is to enumerate System fonts with EnumFontFamilies API.
Here's a modified version of the code available in VB help files. Create a listbox on a new form and either call the FillListWithFonts
procedure from the form's OnOpen event or from the OnClick event of a command button.

Call FillListWithFonts(Me!List0)

'************* Code Start **************
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64

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 NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type

' ntmFlags field flags
Private Const NTM_REGULAR = &H40&
Private Const NTM_BOLD = &H20&
Private Const NTM_ITALIC = &H1&

' tmPitchAndFamily flags
Private Const TMPF_FIXED_PITCH = &H1
Private Const TMPF_VECTOR = &H2
Private Const TMPF_DEVICE = &H8
Private Const TMPF_TRUETYPE = &H4

Private Const ELF_VERSION = 0
Private Const ELF_CULTURE_LATIN = 0

' EnumFonts Masks
Private Const RASTER_FONTTYPE = &H1
Private Const DEVICE_FONTTYPE = &H2
Private Const TRUETYPE_FONTTYPE = &H4

Private Declare Function EnumFontFamilies Lib "gdi32" Alias _
"EnumFontFamiliesA" _
(ByVal hDC As Long, _
ByVal lpszFamily As String, _
ByVal lpEnumFontFamProc As Long, _
LParam As Any) _
As Long

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 apiGetFocus Lib "user32" _
Alias "GetFocus" _
() As Long

Function fhWnd(ctl As Control) As Long
On Error Resume Next
ctl.SetFocus
If Err Then
fhWnd = 0
Else
fhWnd = apiGetFocus
End If
On Error GoTo 0
End Function

Function EnumFontFamProc(lpNLF As LOGFONT, _
lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, _
LParam As Control) _
As Long
Dim FaceName As String
Dim FullName As String
Dim strOut As String, strFont As String
On Error Resume Next
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
strOut = LParam.RowSource
strFont = left$(FaceName, InStr(FaceName, vbNullChar) - 1)
If strOut = vbNullString Then
strOut = strFont
Else
strOut = strOut & ";" & strFont
End If
LParam.RowSource = strOut
EnumFontFamProc = 1
End Function

Sub FillListWithFonts(ctl As Control)
Dim hDC As Long
hDC = GetDC(fhWnd(ctl))
ctl.RowSource = vbNullString
EnumFontFamilies hDC, vbNullString, AddrOf("EnumFontFamProc"), ctl
ReleaseDC fhWnd(ctl), hDC
End Sub
'************* Code End **************

P.S. Использование шрифтов
Автор: Вадим от 10.09.2003 1:22:14 Источник ...

Страница 1 из 1

Программирование

Microsoft Access. Файлы mdb и accdb

Тема: Выбор шри...

Поиск

Список форумов

Начало | Forums