2

我想在 Access 2007 功能区中使用 .png 作为自定义图标。

这是我到目前为止所尝试的：

我可以毫无问题地将 .bmp 和 .jpg 作为自定义图像加载。我可以加载 .gif，但它似乎无法保持透明度。我根本无法加载.png。我真的很想使用 .png 来利用其他格式中不可用的 alpha 混合。

我在 SO 上发现了一个类似的问题，但这只是处理加载任何类型的自定义图标。我对.png特别感兴趣。Albert Kallal 对该问题的回答是链接到他编写的一个类模块，该模块似乎完全符合我的要求：

meRib("Button1").Picture = "HappyFace.png"

不幸的是，该答案中的链接已失效。

我还发现这个站点提供了一个 460 行模块的下载，其中包含数十个 API 调用以获得对透明图标的支持。在我走那条路之前，我想问问这里的专家他们是否知道更好的方法。

我知道 .png 是相当新奇的，但我希望 Office 开发人员能够对该格式提供一些本机支持。

4

1 回答 1

3

这是我目前正在使用的。Albert Kallal 为 Access 2007 功能区编程提供了一个更成熟的解决方案，它不仅可以加载 .png 文件。我还没有使用它，但值得一试。

对于那些感兴趣的人，这是我正在使用的代码。我相信这非常接近 .png 支持所需的最低要求。如果这里有任何无关的东西，请告诉我，我会更新我的答案。

将以下内容添加到标准代码模块：

Option Compare Database
Option Explicit

'================================================================================
'  Declarations required to load .png's in Ribbon
Private Type GUID
    Data1                   As Long
    Data2                   As Integer
    Data3                   As Integer
    Data4(0 To 7)           As Byte
End Type

Private Type PICTDESC
    Size                        As Long
    Type                        As Long
    hPic                        As Long
    hPal                        As Long
End Type

Private Type GdiplusStartupInput
    GdiplusVersion              As Long
    DebugEventCallback          As Long
    SuppressBackgroundThread    As Long
    SuppressExternalCodecs      As Long
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, _
    inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, _
    hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, _
    RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'================================================================================

Public Sub GetRibbonImage(ctl As IRibbonControl, ByRef image)
Dim Path As String
    Path = Application.CurrentProject.Path & "\Icons\" & ctl.Tag
    Set image = LoadImage(Path)
End Sub

Private Function LoadImage(ByVal strFName As String) As IPicture
    Dim uGdiInput As GdiplusStartupInput
    Dim hGdiPlus As Long
    Dim hGdiImage As Long
    Dim hBitmap As Long

    uGdiInput.GdiplusVersion = 1

    If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
        If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
            GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
            Set LoadImage = ConvertToIPicture(hBitmap)
            GdipDisposeImage hGdiImage
        End If
        GdiplusShutdown hGdiPlus
    End If

End Function

Private Function ConvertToIPicture(ByVal hPic As Long) As IPicture

    Dim uPicInfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim IPic As IPicture

    Const PICTYPE_BITMAP = 1

    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPic
        .hPal = 0
    End With

    OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

    Set ConvertToIPicture = IPic
End Function

然后，如果您还没有，请添加一个名为USysRibbons. （注意：Access 将此表视为系统表，因此您必须通过访问选项 --> 当前数据库 --> 导航选项在导航窗格中显示这些表，并确保选中“显示系统对象”。 ) 然后将这些属性添加到您的控制标签：

getImage="GetRibbonImage" tag="Acq.png"

例如：

<button id="MyButtonID" label="Do Something" enabled="true" size="large"
getImage="GetRibbonImage" tag="MyIcon.png" onAction="MyPublicSub"/>
于 2011-03-06T21:26:12.487 回答