|
楼主 |
发表于 2019-1-22 16:13
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
1.5 第一章总结
MSChart控件的对象非常多,对图表元素的操控也会很细致,如果本教程对所有图表元素的操作都一一举例,教程会变得非常庞大。因此,我把对图表元素的操作全部写在代码里,大家可以在窗体上点击组合框的选项就可以看到操作结果,既可以对图表元素有个直观的认识,也可在需要的时候直接复制相关代码。为了实现在窗体上直观演示,我多写了10倍的代码量,这个方法看来不是很明智,至少对我而言是这样。这里提一下,获取系统字体的方法。论坛上的大神用如下简单的代码就获取了系统的字体:
With Application.CommandBars.FindControl(ID:=1728)
For i = 1 To .ListCount
Cells(i, 1) = .List(i)
Next
End With
不过这个方法不通用,不同版本的EXCEL的ID可能不同,有些版本会什么也获取不到。于是我查阅了微软的资料,用API实现字体的获取,这样通用性应该好些,顺便把安装字体和卸载字体的代码一并提供,这样谁想设计一个小软件的时候,可以直接复制代码,也应该不错的。代码可供参考:
'获取系统字体清单
Private Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal lParam As Long, ByVal dw As Long) 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 Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Const ANSI_CHARSET = 0
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(1 To LF_FACESIZE) As Byte
End Type
Private Type ENUMLOGFONTEX
elfLogFont As LOGFONT
elfFullName(1 To LF_FULLFACESIZE) As Byte
elfStyle(1 To LF_FACESIZE) As Byte
elfScript(1 To LF_FACESIZE) As Byte
End Type
Public frmname As String
Public cmbname As String
Public frm As Object
'
'参考资料:
'https://docs.microsoft.com/zh-cn/windows/desktop/api/wingdi/nf-wingdi-enumfontfamiliesexa
'ivccav 2019/1/15
Private Function EnumFontFamExProc(ByRef lpelfe As ENUMLOGFONTEX, ByVal lpntme As Long, ByVal FontType As Long, ByVal lParam As Long) As Long
Dim fn$, pos&
fn = StrConv(lpelfe.elfLogFont.lfFaceName, vbUnicode)
pos = InStr(fn, Chr$(0))
If pos Then fn = Left$(fn, pos - 1)
With frm.Controls(cmbname)
.AddItem fn
End With
EnumFontFamExProc = 1
End Function
Public Sub GetAllFonts()
Dim lf As LOGFONT
Dim hDC&, f As Object
Dim bln As Boolean
For Each f In UserForms
If f.Name = frmname Then bln = True: Exit For
Next
If bln Then Set frm = f Else Exit Sub
lf.lfCharSet = ANSI_CHARSET
hDC = GetDC(0&)
EnumFontFamiliesEx hDC, lf, AddressOf EnumFontFamExProc, 0&, 0&
ReleaseDC 0&, hDC
End Sub
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
'参考资料:
'https://docs.microsoft.com/zh-cn/windows/desktop/api/wingdi/nf-wingdi-addfontresourcea
''ivccav 2019/1/15
Public Sub AddNewFont() '安装字体
Dim lRet As Long, FontPath As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = "C:\Windows\Fonts\"
.Filters.Clear
.Filters.Add "字体文件", "*.ttf;*.ttc;*.otf"
.Title = "请选择要安装的字体文件"
If .Show = True Then
FontPath = .SelectedItems.Item(1)
lRet = AddFontResource(FontPath)
If lRet = 0 Then
MsgBox "添加字体失败!", vbCritical
Exit Sub
Else
SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
MsgBox "添加字体成功", vbInformation
End If
End If
End With
End Sub
Public Sub RemoveFont() '卸载字体
Dim lRet As Long, FontPath As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = "C:\Windows\Fonts\"
.Filters.Clear
.Filters.Add "字体文件", "*.ttf;*.ttc;*.otf"
.Title = "请选择要卸载的字体文件"
If .Show = True Then
FontPath = .SelectedItems.Item(1)
lRet = RemoveFontResource(FontPath)
If lRet = 0 Then
MsgBox "卸载字体失败!", vbCritical
Exit Sub
Else
SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
MsgBox "卸载字体成功", vbInformation
End If
End If
End With
End Sub
|
|