用字体名称填充组合框

Question

我想在初始化用户窗体时使用电脑上的可用字体填充用户窗体上的组合框。我已经为它写了一个代码，但它只是给我一个错误：

Run-time error '-2147467259 (80004005)':
Method 'ListCount' of Object '_CommanBarComboBox' failed

我试过将 i = 1 修改为 i = 0，但没有帮助。

Private Sub UserForm_Initialize()
Image3.Visible = False
Image6.Visible = False

Dim FontList
Dim i
CreatePapers.ComboBox1.Clear
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
For i = 1 To FontList.ListCount
CreatePapers.ComboBox1.AddItem FontList.List(i + 1)
Next i
End Sub

编辑：

我修改了代码，错误消失了，但是组合框中没有任何内容。

 Dim FontList As CommandBarControl
Dim i As Long
Dim Tempbar As CommandBar
CreatePapers.ComboBox1.Clear

On Error Resume Next
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
 ' If Font control is missing, create a temp CommandBar
    If FontList Is Nothing Then
        Set Tempbar = Application.CommandBars.Add
        Set FontList = Tempbar.Controls.Add(ID:=1728)
   End If
    
For i = 1 To FontList.ListCount
Debug.Print FontList.List(i)
        CreatePapers.ComboBox1.AddItem FontList.List(i)
    Next i
    Me.ComboBox1.ListIndex = 0

'   Delete temp CommandBar if it exists
    On Error Resume Next
    Tempbar.Delete

编辑 2： 如 T.M 所述，在上述修改后的代码中添加了 2 行代码。 , 但它仍然没有填满组合框，它只是空的。

编辑 3： 更改了代码中的某些行，但它仍然没有检索到字体。 FontList 也是空的，即使在 If FontList Is Nothing Then 部分之后，它创建了临时控制栏。

Answer 1

您正在访问不存在的 FontList 项目。你的 for-loop 没问题。但是，您需要将里面的行更改为：

CreatePapers.ComboBox1.AddItem FontList.List(i)

访问索引 + 1 超出了列表的范围，这就是崩溃的原因。

您的代码应如下所示：

Private Sub UserForm_Initialize()
Image3.Visible = False
Image6.Visible = False
Dim FontList
Dim i
CreatePapers.ComboBox1.Clear
Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
For i = 1 To FontList.ListCount
    CreatePapers.ComboBox1.AddItem FontList.List(i)
Next i
End Sub

Answer 2

您可以通过将完整的数组分配给组合框 .List 属性:

来缩短初始化过程，使其更易读

Private Sub UserForm_Initialize()
    Me.ComboBox1.List = GetFontList()    ' << calling `GetFontList()  
End Sub

数组本身是以下函数的结果：

Option Explicit

Function GetFontList() As Variant
    Dim FontList As CommandBarControl    ' << declare type
    On Error Resume Next                 ' provide for missing font control
    Set FontList = Application.CommandBars("Formatting").FindControl(id:=1728)
    On Error GoTo 0
    'If Font control is missing, create it on a temporary CommandBar
    If FontList Is Nothing Then
        Dim tmpBar As CommandBar
        Set tmpBar = Application.CommandBars.Add
        Set FontList = tmpBar.Controls.Add(id:=1728)
    End If

    Dim tmpList: ReDim tmpList(1 To FontList.ListCount, 1 To 1)
    'Assign fonts to array
    Dim i As Long
    For i = 1 To UBound(tmpList)
        tmpList(i, 1) = FontList.List(i)
    Next i
    
    'Delete temporary CommandBar eventually
    On Error Resume Next
    tmpBar.Delete
    'return 2-dim 1-based font array as function result
    GetFontList = tmpList
End Function

进一步提示

CommandBarControl 项目可以通过一个索引通过

寻址

FontList.List(i)

*) 组合框的二维 .List 属性基于 0，但也接受赋值一个基于的数组（由上述函数返回）。

用字体名称填充组合框

Populate Combobox with font names

excel

vba

excel-2013