提取 Office 2016 工具栏图标

最新推荐文章于 2024-05-11 20:26:42 发布

blackwood-cliff

最新推荐文章于 2024-05-11 20:26:42 发布

阅读量6.5k

点赞数 8

分类专栏： VBA 文章标签： VBA Office Icon

本文链接：https://blog.csdn.net/blackwoodcliff/article/details/89891405

版权

VBA 专栏收录该内容

1 篇文章 0 订阅

订阅专栏

Office 图标精美漂亮，作为微软的官方图标，与 Windows 具有一致的风格，但我们若想把这些图标用在自己的程序中，却并不容易，使用常规的提取程序资源的方法，根本得不到这些图标。
微软虽然没有把这些图标开放给我们下载使用，但在 Office VBA 中，微软却是允许我们随意使用的。通过调用 CommandBars.GetImageMso 方法，我们可以得到指定控件的图标。
CommandBars.GetImageMso 方法的第一个参数，要求提供控件的标识符。那么我们怎么知道 Office 中有哪些控件，标识符又是什么呢？在这方面，微软做的还是非常好的，Office Fluent UI Command Identifiers (https://github.com/OfficeDev/office-fluent-ui-command-identifiers)，在这个网址，微软提供了 Office 所有控件的标识符。

本篇文章中，我们将新建一个 Excel 文件，并创建一个用户窗体，在用户窗体上显示一些带图标的按钮，点击按钮即可将按钮上的图标导出到 PNG 文件。

创建窗体

在窗体上摆放 500 个按钮，用于显示图标。由于图标较多，有几千个，再在窗体上放一个 TabStrip，用于切换显示的图标。

Private Sub AddControls()
    Set tabStrip1 = Me.Controls.Add("Forms.TabStrip.1", "tabStrip1", True)
    With tabStrip1
        .Left = 0
        .Top = 0
        .Width = 860
        .Height = 705
    End With
    
    tabStrip1.Tabs(0).Caption = "1-500"
    tabStrip1.Tabs(1).Caption = "501-1000"
    
    Dim num As Integer
    For num = 1000 To 7000 Step 500
        tabStrip1.Tabs.Add "Forms.Tab." & (tabStrip1.Tabs.Count + 1), (num + 1) & "-" & (num + 500)
    Next num
    
    Set CheckBox1 = Me.Controls.Add("Forms.CheckBox.1", "checkBox1", True)
    With CheckBox1
        .Caption = "大图标"
        .Left = 800
        .Top = 0
        .Width = 45
        .Height = 15
        .Value = True
    End With
    
    Dim CmdBtn As MSForms.CommandButton
    Dim rows As Integer
    Dim cols As Integer
    For rows = 1 To 20
        For cols = 1 To 25
            Set CmdBtn = Me.Controls.Add("Forms.CommandButton.1", "commandButton" & rows & cols)
            With CmdBtn
                .Name = "image" & ((rows - 1) * 25 + cols)
                .Left = 5 + 34 * (cols - 1)
                .Top = 18 + 34 * (rows - 1)
                .Width = 34
                .Height = 34
                .PicturePosition = fmPicturePositionCenter
            End With
        Next cols
    Next rows
End Sub

在这里插入图片描述

显示图标

获取 Office 图标的唯一方法 CommandBars.GetImageMso，用这个方法得到图标后，赋值给按钮的 Picture 属性。

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

在这里插入图片描述

导出图标

要把图标导出到 PNG 文件，首先想到的就是使用 GDI+。GDI 不能处理 PNG 格式，可用 GDI+ 的 GdipCreateBitmapFromHBITMAP 函数把 StdPicture 转换成 GDI+ 的 Bitmap，然后再用 GdipSaveImageToFile 函数保存到 PNG 格式文件。
图样图森破，用这个方法虽然确实导出了 PNG 图片，但导出的 PNG 图片背景是白色的，这并不是我想要的结果，我希望导出的是背景透明的 PNG 图片。

试错

背景不透明，毫无疑问是 Alpha 值的问题。所以首先就想到，把转换来的 GDI+ 的 Bitmap 的 Alpha 值，根据原始图片的 Alpha 值重新设置一遍，然后再保存。具体思路是：

使用 GetDIBits 函数，获得通过 GetImageMso 得到的 StdPicture 的原始数据
使用 GdipBitmapGetPixel 函数取得 GDI+ 的 Bitmap 的每个像素值
根据原始数据，修改每个像素的 Alpha 值
使用 GdipBitmapSetPixel 函数，把修改 Alpha 后的像素值写回 Bitmap
保存成 PNG 图片

经过实践，发现执行 GdipBitmapSetPixel 函数后，各个像素的 Alpha 值并没有改变，导出的图片仍然是白色背景。

再试错

接着上面的思路，既然单独修改 Alpha 值不好用，那么干脆就把 GDI+ Bitmap 的图像数据全部替换成原始数据。具体步骤是：

使用 GetDIBits 函数，获得通过 GetImageMso 得到的 StdPicture 的原始数据
使用 GdipBitmapLockBits 函数取得 GDI+ 的 Bitmap 的图像数据
把得到的 GDI+ Bitmap 的图像数据替换成 StdPicture 的原始数据
使用 GdipBitmapUnlockBits 函数把修改后的图像数据写回 Bitmap
保存成 PNG 图片

实践之后，发现虽然 Alpha 值改变了，但导出的图片仍然是白色背景。这是为什么呢？

发现原因

突然想到，GDI+ Bitmap 有多种像素格式，那么使用 GdipCreateBitmapFromHBITMAP 函数得到的 Bitmap 的 PixelFormat 是什么呢？
通过 GdipGetImagePixelFormat 函数得到 Bitmap 的 PixelFormat，发现是 PixelFormat32bppRGB。
这就不对了，透明背景的 Bitmap，PixelFormat 应该是 PixelFormat32bppARGB，上面的格式里明显少了一个 A，而正是这个 A 表示图像是否能够透明。
至此，就可以很容量理解上面一再试错仍不成功的原因了。无论修改 Alpha 值也好，还是替换整个图像数据也好，但 Bitmap 的 PixelFormat 仍然没有变，依然是 PixelFormat32bppRGB，是不支持透明的。要想让图片透明，必须把 PixelFormat 变成支持透明的格式。

创建透明 Bitmap

发现了问题原因，解决办法就很容易找到了。
既然 GdipCreateBitmapFromHBITMAP 函数得到的 Bitmap 是不透明的，那么就没必要在这上面折腾了，不如直接创建一个支持透明的图片。具体思路是：

使用 GetDIBits 函数，获得通过 GetImageMso 得到的 StdPicture 的原始数据
使用 GdipCreateBitmapFromScan0 函数创建一个 PixelFormat32bppARGB 格式的 Bitmap
使用 GdipBitmapLockBits 函数取得 Bitmap 的图像数据区
复制 StdPicture 的原始数据到 Bitmap 的图像数据区
使用 GdipBitmapUnlockBits 函数把图像数据写回到 Bitmap
把 Bitmap 保存成 PNG 图片

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

后记

在写本文时，发现了两个函数：

GdipBitmapConvertFormat
Bitmap.MakeTransparent

第一个函数 GdipBitmapConvertFormat 用于转换像素格式，那么我们把由 GdipCreateBitmapFromHBITMAP 函数得到的 Bitmap 的 PixelFormat 转换成 PixelFormat32bppARGB，然后再修改 Alpha 值，是不是就可以生成透明背景的 PNG 了？
GdipBitmapConvertFormat 可以参考 https://bbs.csdn.net/topics/390320347
第二个函数 Bitmap.MakeTransparent 是 .NET 里 Bitmap 类的 MakeTransparent 方法。这个方法可以把指定的颜色变为透明色。那么是不是可以考虑通过 Office PIA 的 CommandBarsClass.GetImageMso 得到图标，再用 Image.FromHbitmap 转换成 GDI+ Bitmap。此时得到的图片应该是白色背景的，这时候再用 Bitmap.MakeTransparent 方法把白色变为透明色，然后用 Bitmap.Save 方法保存成 PNG 格式图片。
但是仔细想想，如果图标中有白色的话，是不是也给变成透明色了，看来这个 Bitmap.MakeTransparent 还是不太适用。

源码下载

https://download.csdn.net/download/blackwoodcliff/11180913

此源码只适用于 32 位 Office，若要在 64 位 Office 上使用，需做如下修改：

将 Long 型变量替换成 LongLong 型
声明 API 函数的语句中的 Declare 后面要加 PtrSafe

参考

blackwood-cliff

关注

8
点赞
踩
18

收藏

觉得还不错? 一键收藏
2
评论
提取 Office 2016 工具栏图标

Office 图标精美漂亮，作为微软的官方图标，与 Windows 具有一致的风格，但我们若想把这些图标用在自己的程序中，却并不容易，使用常规的提取程序资源的方法，根本得不到这些图标。微软虽然没有把这些图标开放给我们下载使用，但在 Office VBA 中，微软却是允许我们随意使用的。通过调用 CommandBars.GetImageMso 方法，我们可以得到指定控件的图标。CommandBa...
复制链接

扫一扫