VBA 提取 Office 2016 工具栏图标

古城微笑少年丶 2022-11-18 05:52 223阅读 0赞

Office 图标精美漂亮，作为微软的官方图标，与 Windows 具有一致的风格

获取 Office 图标的唯一方法 [CommandBars.GetImageMso][]

Private Sub ShowImages()
        On Error Resume Next
        Dim idx As Integer, imgIdx As Integer
        Dim btn As MSForms.CommandButton
        Dim pic As IPictureDisp
        Dim ImgSize As Long
        
        If CheckBox1.Value = True Then ImgSize = 32 Else ImgSize = 16
        
        For idx = 1 To 500
            imgIdx = idx + 500 * tabStrip1.Value
            Set btn = Me.Controls.Item("image" & idx)
            If imgIdx <= 7345 Then
                Set pic = Nothing
                Set pic = Application.CommandBars.GetImageMso(Replace(Range("A" & imgIdx).Value, Chr(34), ""), ImgSize, ImgSize)
                With btn
                    .Visible = True
                    .Caption = ""
                    .Picture = pic
                    .ControlTipText = imgIdx & "-" & Replace(Range("A" & imgIdx).Value, Chr(34), "")
                End With
            Else
                btn.Visible = False
            End If
        Next idx
    End Sub

![watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L2VqaW54aWFu_size_16_color_FFFFFF_t_70][]

Public Sub HBITMAPToBitmapARGB(gdiHdc As Long, gdiHBITMAP As Long, gdipBitmap As Long)
        Dim bmi As BITMAPINFO
        Dim bBits() As Byte
        
        GetDIBitsInfo gdiHdc, gdiHBITMAP, bmi
        GetDIBitsData gdiHdc, gdiHBITMAP, bmi, bBits
        
        Dim bmWidth As Long, bmHeight As Long
        
        bmWidth = bmi.bmiHeader.biWidth
        bmHeight = Abs(bmi.bmiHeader.biHeight)
        
        Dim rc As RECTL
        rc.Left = 0
        rc.Top = 0
        rc.Right = bmWidth
        rc.Bottom = bmHeight
        
        Dim data() As Byte
        ReDim data(rc.Right * 4 - 1, rc.Bottom - 1)
        
        Dim BmpData As BitmapData
        With BmpData
            .Width = rc.Right
            .Height = rc.Bottom
            .PixelFormat = GpPixelFormat.PixelFormat32bppARGB
            .scan0 = VarPtr(data(0, 0))
            .stride = 4 * CLng(rc.Right)
        End With
        
        Dim lineSize As Long
        lineSize = iIconBPP / 8 * bmWidth
        
        Dim x As Long, y As Long, z As Long
        Dim lineStart As Long, colorStart As Long
        
        CreateBitmap gdipBitmap, bmWidth, bmHeight, PixelFormat32bppARGB
        
        GdipBitmapLockBits gdipBitmap, rc, ImageLockModeUserInputBuf Or ImageLockModeWrite Or ImageLockModeRead, GpPixelFormat.PixelFormat32bppARGB, BmpData
        
        For y = 0 To bmHeight - 1
            lineStart = (bmHeight - y - 1) * lineSize
            CopyMemory ByVal VarPtr(data(0, y)), ByVal VarPtr(bBits(lineStart)), lineSize
        Next
        
        GdipBitmapUnlockBits gdipBitmap, BmpData
    End Sub

原文：[https://blog.csdn.net/blackwoodcliff/article/details/89891405][https_blog.csdn.net_blackwoodcliff_article_details_89891405]

[CommandBars.GetImageMso]: https://docs.microsoft.com/zh-cn/office/vba/api/Office.CommandBars.GetImageMso
[watermark_type_ZmFuZ3poZW5naGVpdGk_shadow_10_text_aHR0cHM6Ly9ibG9nLmNzZG4ubmV0L2VqaW54aWFu_size_16_color_FFFFFF_t_70]: /images/20221022/4ab2c142987f4d56a56f42f56ab224b1.png
[https_blog.csdn.net_blackwoodcliff_article_details_89891405]: https://blog.csdn.net/blackwoodcliff/article/details/89891405