Ich habe einen neuen PC Win8.1 64Bit mit Office 2010 32Bit Version 14.0.7015.1000.
In meiner AccdessDB rufe ich eine API auf um Schriften an zu zeigen. Diese wird von Microsoft genau so empfohlen.
Option Compare Database
Option Explicit
'Font enumeration types
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
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
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
Type tyFontInfoNead
stName As String
intHohe As Integer
boItalic As Boolean
boUnerline As Boolean
intFett As Integer
intTxtAusricht As Integer
lngForeCol As Long
lngBackcol As Long
intTransp As Integer
End Type
Global glbTxtInfo As tyFontInfoNead
' ntmFlags field flags
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
' tmPitchAndFamily flags
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
' EnumFonts Masks
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Declare Function EnumFontFamilies Lib "gdi32" Alias _
"EnumFontFamiliesA" _
(ByVal hdc As Long, ByVal lpszFamily As String, _
ByVal lpEnumFontFamProc As Long, lParam As Any) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, lParam As ListBox) As Long
Dim FaceName As String
Dim FullName As String
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
lParam.RowSource = lParam.RowSource & ";" & Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
EnumFontFamProc = 1
End Function
Sub FillListWithFonts(LB As ListBox)
Dim hdc As Long, ll As ListBox
On Error Resume Next
LB.RowSource = ""
hdc = GetDC(CodeContextObject.hWnd)
EnumFontFamilies hdc, vbNullString, AddressOf EnumFontFamProc, LB
End Sub
Public Sub subFillFontTyp(boIt As Boolean, boUnd As Boolean, intF As Integer, _
intH As Integer, intTA As Integer, intTR As Integer, _
lngB As Long, lngFo As Long, stName As String)
'Schreibt die Fontinformationen in einen Typ-Array
If stName = "" Then Exit Sub
glbTxtInfo.stName = stName
glbTxtInfo.boItalic = boIt
glbTxtInfo.boUnerline = boUnd
glbTxtInfo.intFett = intF
glbTxtInfo.intHohe = intH
glbTxtInfo.intTxtAusricht = intTA
glbTxtInfo.intTransp = intTR
glbTxtInfo.lngBackcol = lngB
glbTxtInfo.lngForeCol = lngFo
End Sub
Public Sub subSetFontInfo(crtInfo As Control)
'Übergibt die Fontinformationen des übergebenen Feldes
'an eine Prozedur die dann den Globalen Typen abfüllt
With crtInfo
subFillFontTyp .Fontitalic, .FontUnderline, .FontWeight, .Fontsize, .TextAlign, .BackStyle, .Backcolor, .ForeColor, .FontName
End With
End Sub
Public Sub subGetFontInfoToCrt(crtInfo As Control, Optional ausrich As Variant = True, Optional varGroesse As Variant = True)
On Error Resume Next
'Prozedur übergibt die Fontinformationen an das übergebene
'Feld
If glbTxtInfo.stName = "0" Or glbTxtInfo.stName = "" Then Exit Sub
With crtInfo
.Fontitalic = glbTxtInfo.boItalic
.FontUnderline = glbTxtInfo.boUnerline
.FontWeight = glbTxtInfo.intFett
If varGroesse Then .Fontsize = glbTxtInfo.intHohe
If ausrich Then .TextAlign = glbTxtInfo.intTxtAusricht
.BackStyle = glbTxtInfo.intTransp
.Backcolor = glbTxtInfo.lngBackcol
.ForeColor = glbTxtInfo.lngForeCol
.FontName = glbTxtInfo.stName
End With
End Sub
Leider bekomme ich an folgender Stelle eine Fehlermaldung.
EnumFontFamilies hdc, vbNullString, AddressOf EnumFontFamProc, LB
Was ist hier Falsch?
Besten Dank für Typs und Infos
