從工作表用戶窗體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中編輯了背景顏色以匹配用戶界面的顏色。

現在，一旦導入，圖像背景似乎是透明的，因此看起來是圓形的。