从工作表用户窗体Excel取整图像

Question

我想知道是否可以在Excel用户窗体上显示以下图像（圆形）：

图片http://im82.gulfup.com/E7phxt.png

或至少我想显示以保持图像的透明度，因为相框似乎不接受PNG格式。

用户表单http://im75.gulfup.com/LJj6ES.png

我的第二个更大的问题是，我想直接从excel工作表“ Sheet1”将图像加载到UserForm中，在该工作表中 ，我将插入的图像命名为：usflag，canadaflag，mexicoflag等。

Excel http://im75.gulfup.com/1uJ8cg.png

这样做的原因是工作表将被共享，并且我不想将图片路径链接到必须与工作表一起共享的特定文件夹。

非常感谢您的帮助。

Answer 1

我有这样的解决方案。 表单中的图像背景不是真正透明的。 Excel工作表中的图像是PNG，透明背景位于彩色的Excel单元格填充上，然后复制到用户窗体中。 开始：

• 将图像加载到Excel中。
• 将工作表背景设置为所需的颜色，即您在用户窗体中使用的颜色。
• 选择一个包含您的地球仪的矩形范围，然后使用“复制为图片”
• 粘贴到电子表格中，并将其名称从“ Picture 1更改为“ SelectedFlag
• 创建一个名为PictureSource的范围名称，并为其分配先前为图像选择的范围
• 选择粘贴的图像，然后在编辑栏中键入a =符号，后跟范围名称PictureSource
  • 现在，您可以创建一些逻辑（在VBA中或使用动态范围名称公式），以在满足特定条件（例如，国家/地区字段具有特定值）时更改PictureSource的引用。 测试这是否有效，即，如果您运行VBA或更改特定的单元格值，则SelectedFlag显示的图像会更改。
  • 以上所有情况均发生在名为“ TheHiddenSheet”的工作表上
  • 在用户窗体上，插入所需尺寸的图像控件，并将其名称命名为Image1
  • 初始化表单时，请使用一些代码来复制隐藏工作表中的图像并将其粘贴到表单的Image1上。

这是我使用的代码

Private Sub UserForm_Initialize()
    Worksheets("TheHiddenSheet").Shapes("SelectedFlag").Copy
    Set Image1.Picture = PastePicture()
End Sub

PastePicture()命令不是Excel的本机功能，而是Steve Bullen编写的一段代码。 您需要创建一个常规模块，并在其中粘贴以下代码：

'*--------------------------------
'*
'* MODULE NAME:     Paste Picture
'* AUTHOR & DATE:   STEPHEN BULLEN, Office Automation Ltd
'*                  15 November 1998
'*
'* CONTACT:         Stephen@oaltd.co.uk
'* WEB SITE:        http://www.oaltd.co.uk
'*
'* DESCRIPTION:     Creates a standard Picture object from whatever is on the clipboard.
'*                  This object can then be assigned to (for example) and Image control
'*                  on a userform.  The PastePicture function takes an optional argument of
'*                  the picture type - xlBitmap or xlPicture.
'*
'*                  The code requires a reference to the "OLE Automation" type library
'*
'*                  The code in this module has been derived from a number of sources
'*                  discovered on MSDN.
'*
'*                  To use it, just copy this module into your project, then you can use:
'*                      Set Image1.Picture = PastePicture(xlPicture)
'*                  to paste a picture of whatever is on the clipboard into a standard image control.
'*
'* PROCEDURES:
'*   PastePicture   The entry point for the routine
'*   CreatePicture  Private function to convert a bitmap or metafile handle to an OLE reference
'*   fnOLEError     Get the error text for an OLE error code
'*----------------------------

Option Explicit
Option Compare Text

'----------------------------
' User-Defined Types for API Calls '
'----------------------------

'Declare the GUID Type structure for the IPicture OLE Interface
 Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
 End Type

'Declare the Picture Description Type structure
 Private Type PICTDESC
    Size As Long
    Type As Long
    hPic As Long     'Holds the handle to a .bmp, .emf, .ico, .wmf file
    Data1 As Long    'For a .bmp this holds the pallete handle hPal. For a .wmf this hold the xExt value.
    Data2 As Long    'Used only with a .wmf to hold the yExt value.
 End Type

'----------------------------
' Windows API Function Declarations '
'----------------------------

'Does the clipboard contain a bitmap/metafile?
 Private Declare Function IsClipboardFormatAvailable _
     Lib "user32.dll" _
         (ByVal wFormat As Integer) _
     As Long

'Open the clipboard to read and write data
 Private Declare Function OpenClipboard _
     Lib "user32.dll" _
         (ByVal hWnd As Long) _
     As Long

'Get a pointer to the bitmap/metafile
 Private Declare Function GetClipboardData _
     Lib "user32.dll" _
         (ByVal wFormat As Integer) _
     As Long

'Copy data to the clipboard
 Private Declare Function SetClipboardData _
     Lib "user32.dll" _
         (ByVal uFormat As Long, _
          ByVal hData As Long) _
     As Long

'Empty the clipboard
 Private Declare Function EmptyClipboard _
     Lib "user32.dll" () As Long

'Close the clipboard
 Private Declare Function CloseClipboard _
     Lib "user32.dll" () As Long

'Convert the handle into an OLE IPicture interface.
 Private Declare Function OleCreatePictureIndirect _
     Lib "olepro32.dll" _
         (ByRef pPictDesc As PICTDESC, _
          ByRef riid As GUID, _
          ByVal fOwn As Long, _
          ByRef ppvObj As IPicture) _
     As Long

'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.
 Declare Function CopyEnhMetaFile _
     Lib "GDI32.dll" Alias "CopyEnhMetaFileA" _
         (ByVal hemfSrc As Long, _
          ByVal lpszFile As String) _
     As Long

'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.
 Declare Function CopyImage _
     Lib "user32.dll" _
         (ByVal hImage As Long, _
          ByVal uType As Long, _
          ByVal cxDesired As Long, _
          ByVal cyDesired As Long, _
          ByVal fuFlags As Long) _
     As Long

'The API Constants needed
 Const CF_BITMAP = &H2
 Const CF_ENHMETAFILE = &HE
 Const CF_METAFILEPICT = &H3
 Const CF_PALETTE = &H9
 Const IMAGE_BITMAP = &H0
 Const IMAGE_ICON = &H1
 Const IMAGE_CURSOR = &H2
 Const LR_COPYRETURNORG = &H4


Public Function PastePicture(Optional xlPicType As Long = xlPicture) As IPicture

  'Some pointers
   Dim hClip As Long
   Dim hCopy As Long
   Dim hObj As Long
   Dim hPal As Long
   Dim hPicAvail As Long
   Dim PicType As Long
   Dim RetVal As Long

   'Convert the Excel picture type constant to the correct API constant
    PicType = IIf(xlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)

   'Check if the clipboard contains the required format
    hPicAvail = IsClipboardFormatAvailable(PicType)

      If hPicAvail <> 0 Then
        'Get access to the clipboard
         hClip = OpenClipboard(0&)

          If hClip > 0 Then
            'Get a handle to the object
             hObj = GetClipboardData(PicType)

              'Create a copy of the clipboard image in the appropriate format.
               If PicType = CF_BITMAP Then
                  hCopy = CopyImage(hObj, IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
               Else
                  hCopy = CopyEnhMetaFile(hObj, vbNullString)
               End If

            'Release the clipboard to other programs
             RetVal = CloseClipboard

            'If there is a handle to the image, convert it into a Picture object and return it
             If hObj <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, PicType)
          End If
      End If

End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal PicType) As IPicture

  'IPicture requires a reference to "OLE Automation"
   Dim Ref_ID As GUID
   Dim IPic As IPicture
   Dim PicInfo As PICTDESC
   Dim RetVal As Long

  'OLE Picture types
   Const PICTYPE_UNINITIALIZED = -1
   Const PICTYPE_NONE = 0
   Const PICTYPE_BITMAP = 1
   Const PICTYPE_METAFILE = 2
   Const PICTYPE_ICON = 3
   Const PICTYPE_ENHMETAFILE = 4

  'Create a UDT to hold the reference to the interface ID (riid).
  'IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  'StdPicture GUID {0BE35204-8F91-11CE-9DE3-00AA004BB851}
   With Ref_ID
    .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

  'Fill PicInfo structure
   With PicInfo
     .Size = Len(PicInfo)                                                    ' Length of structure.
     .Type = IIf(PicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)   ' Type of Picture
     .hPic = hPic                                                            ' Handle to image.
     .Data1 = IIf(PicType = CF_BITMAP, hPal, 0&)                             ' Handle to palette (if bitmap).
     .Data2 = 0&
   End With

    'Create the Picture object.
     RetVal = OleCreatePictureIndirect(PicInfo, Ref_ID, True, IPic)

      'Check if an error ocurred
       If RetVal <> 0 Then
          MsgBox "Create Picture Failed - " & GetErrMsg(RetVal)
          Set IPic = Nothing
          Exit Function
       End If

    'Return the new Picture object.
     Set CreatePicture = IPic

End Function

Private Function GetErrMsg(ErrNum As Long) As String

  'OLECreatePictureIndirect return values
   Const E_ABORT = &H80004004
   Const E_ACCESSDENIED = &H80070005
   Const E_FAIL = &H80004005
   Const E_HANDLE = &H80070006
   Const E_INVALIDARG = &H80070057
   Const E_NOINTERFACE = &H80004002
   Const E_NOTIMPL = &H80004001
   Const E_OUTOFMEMORY = &H8007000E
   Const E_POINTER = &H80004003
   Const E_UNEXPECTED = &H8000FFFF

     Select Case ErrNum
       Case E_ABORT
         GetErrMsg = " Aborted"
       Case E_ACCESSDENIED
         GetErrMsg = " Access Denied"
       Case E_FAIL
         GetErrMsg = " General Failure"
       Case E_HANDLE
         GetErrMsg = " Bad/Missing Handle"
       Case E_INVALIDARG
         GetErrMsg = " Invalid Argument"
       Case E_NOINTERFACE
         GetErrMsg = " No Interface"
       Case E_NOTIMPL
         GetErrMsg = " Not Implemented"
       Case E_OUTOFMEMORY
         GetErrMsg = " Out of Memory"
       Case E_POINTER
         GetErrMsg = " Invalid Pointer"
       Case E_UNEXPECTED
         GetErrMsg = " Unknown Error"
     End Select

End Function

您将需要建立某种逻辑，以确定应该显示哪个标志/图片。 假设在工作表的单元格A1中存储了国家名称，即美国，加拿大，阿根廷或墨西哥。

确保所有标志图片都位于单元格背景上，在此背景下，您需要选择的范围来捕获图片始终是相同大小。 现在，选择包含美国国旗的范围，并为其指定范围名称“ USA”。 选择包含加拿大国旗的范围，并为其分配范围名称“加拿大”。 冲洗并重复阿根廷和墨西哥。

因此，现在您有四个范围名称，每个标志一个。 现在，根据单元格A1的值，您可以更改“ SelectedFlag”图像中显示的图片。 请记住，此图像链接到名为“ PictureSource”的命名范围。 现在，您可以重新定义该范围的参考并使其动态。

编辑命名范围PictureSource并将其定义更改为

=INDIRECT(Sheet1!$A$1)

当然，这将要求A1中的值和命名范围是完美匹配。 每当A1中的值更改时，动态图像也会更改。 这是带有三个不同图像的这种情况的屏幕截图。

因此，在加载表单之前或加载表单时，您需要进行一些将单元格A1设置为所需国家/地区名称的活动。

Answer 2

没关系，我想通了。

由于Excel VBA不允许我在没有背景的情况下导入PNG图像，因此我只是在Photoshop中编辑了背景颜色以匹配用户界面的颜色。

现在，一旦导入，图像背景似乎是透明的，因此看起来是圆形的。