Excel ControlButton 粘贴面

Question

我有一个 excel sheet 可以制作自定义工具栏。在这个工具栏中，我有几个使用 faceID 的按钮，这没问题。我有几个按钮，我想在其中使用自定义图标。当我使用自定义图标时，PasteFace 有时起作用，有时不起作用，并且出现错误。我添加了 On Error Resume next 语句，以查看发生了什么。有时两个按钮都可以粘贴，有时只有一个按钮，有时两个按钮都没有。我找不到它工作或不工作的模式。

我的工具栏由大约 24 个按钮和一个下拉框组成。其中 11 个按钮使用自定义图标，其余按钮使用 FaceID。一些按钮根据用户需要切换显示或不显示。下面的示例显示了 2 个按钮，它们将切换以打开或关闭餐食惩罚。我只选择了这 2 个按钮，因为它们是第一个使用自定义图标的按钮。

  Sub Make_PayBar()
      
    Dim PayBar As CommandBar
    Dim NewButton As CommandBarButton
    
    'Delete existing PayBar toolbar if it exists
    Call Kill_PayBar
    ThisWorkbook.Activate
    On Error Resume Next
      
    'Create New PayBar
    Set PayBar = Application.CommandBars.Add(Name:="Payroll Bar", Temporary:=True)
    PayBar.Visible = True
    PayBar.Position = msoBarTop
  
    ...  Missing Code, More buttons  ...
    
    'Meal Penalty Off Button
    Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_Off")
    NewButton.Caption = "Meal Penalty Off"
    NewButton.OnAction = "ToggleMeal"
    'NewButton.FaceId = 1254               'Backup if pasteface fails
    Sheets("Pics").Shapes("Meal_Off").Copy
    NewButton.PasteFace
      
    'Meal Penalty On Button
    Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_On")
    NewButton.Caption = "Meal Penalty On"
    NewButton.OnAction = "ToggleMeal"
    'NewButton.FaceId = 1253               'Backup if pasteface fails
    Sheets("Pics").Shapes("Meal_On").Copy
    NewButton.PasteFace
    NewButton.Visible = False
    
    ...  Missing Code, More buttons  ...
    
  End sub

如果不使用Resume Next，则两个pasteface语句中的任何一个都可能出现错误。

我的代码中有什么东西让 PastFace 不可靠吗？

如果 PasteFace 本质上不可靠，有没有办法检查粘贴是否成功，如果不成功则重复？

有更好的方法吗？

Answer 1

工作表具有包含图片和 ActiveX 控件的隐藏集合。 VBA 还有一个隐藏的图片类型。图片有一个 CopyPicture 方法，比 `Shape.Copy.

更一致

按F2打开对象浏览器，右击并选择显示隐藏成员

Function picMeal_Off() As Picture: Set picMeal_Off = ThisWorkbook.Worksheets("Pics").Pictures("Meal_Off"): End Function
Function picMeal_on() As Picture: Set picMeal_on = ThisWorkbook.Worksheets("Pics").Pictures("Meal_on"): End Function

Sub Make_PayBar()
      
    Dim PayBar As CommandBar
    Dim NewButton As CommandBarButton
    Set PayBar = Application.CommandBars.Add(Name:="Payroll Bar", Temporary:=True)
    PayBar.Visible = True
    PayBar.Position = msoBarTop
  
    Set NewButton = PayBar.Controls.Add(Type:=msoControlButton, Parameter:="Meal_Off")
    NewButton.Caption = "Meal Penalty Off"
    NewButton.OnAction = "ToggleMeal"
    picMeal_Off.CopyPicture
    NewButton.PasteFace
End Sub

我使用这个宏创建了引用图片的函数：

Sub PrintPitureDefs(ws As Worksheet)
    Const BaseCode As String = "Function picCodeName() As Picture:Set picCodeName = ThisWorkbook.Worksheets(""WorksheetName"").Pictures(""PictureName""):End Function"
    Dim Code As String
    Dim Img As Picture
    For Each Img In ws.Pictures
        Code = Replace(BaseCode, "WorksheetName", ws.Name)
        Code = Replace(Code, "PictureName", Img.Name)
        Code = Replace(Code, "CodeName", Replace(Img.Name, " ", "_"))
        Debug.Print Code
    Next
End Sub

Excel ControlButton 粘贴面

Excel ControlButton Pasteface

excel

vba

excel-2010