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

Question

I was wondering if it was possible to display the below image as it looks (Circular) on an Excel Userform:

Picture http://im82.gulfup.com/E7phxt.png

Or at least I would like to display to maintain the transparency of the image, as it would appear that the Picture Frame does not accept the PNG format.

Userform http://im75.gulfup.com/LJj6ES.png

My second and bigger problem is that I would like to load the images into the UserForm directly from the excel worksheet "Sheet1" where I named the images that I have inserted as: usflag, canadaflag, mexicoflag, etc.....

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

The reason for doing this is that the sheet will be shared and I do not want to link the picture paths to a particular folder that will have to shared along with the sheet.

Help will be highly appreciated.

Answer 1

I have such a solution in place. The image background in the form is not really transparent. The image in the Excel sheet is a PNG with a transparent background sitting on a colored Excel cell fill and is then copied into the userform. Here goes:

• Load the images into Excel.
• Set the Sheet background to your desired color, ie the color you use in the userform.
• select a rectangular range that includes one of your globe and use "Copy as picture"
• Paste into your spreadsheet and change its name from Picture 1 to SelectedFlag
• Create a range name called PictureSource and assign it the range you previously selected for the image
• Select the pasted image and in the formula bar type a = sign followed by the range name PictureSource
  • you can now create some logic (either in VBA or with a dynamic range name formula) that changes the reference for PictureSource when a specific condition is met, eg when a country field has a specific value. Test that this works, ie if you run the VBA or if you change a specific cell value, the image shown in SelectedFlag changes.
  • all the above happen on the worksheet called "TheHiddenSheet"
  • On your userform, insert an image control of the desired dimensions and let its name be Image1
  • use some code when the form is initialized to copy the image from the hidden sheet and paste it over Image1 of the form.

This is the code I use

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

The PastePicture() command is not a native Excel function, but a piece of code by Steve Bullen. You need to create a regular module and paste the following code there:

'*--------------------------------
'*
'* 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

You will need to establish some kind of logic that determines which flag/picture should be shown. Let's assume in cell A1 in the worksheet you store the name of the country, ie either USA, Canada, Argentina or Mexico.

Make sure all your flag pictures are on a cell background where the range you need to select to capture the picture is always the same size. Now, select the range that contains the US flag and assign it the range name "USA". Select the range that contains the Canadian flag and assign it the range name "Canada". Rinse and repeat for Argentina and Mexico.

So now, you have four range names, one for each flag. Depending on the value of cell A1 you can now change the picture that is showing in the "SelectedFlag" image. Remember that this image is linked to a named range called "PictureSource". You can now re-define the reference for that range and make it dynamic.

Edit the named range PictureSource and change its definition to

=INDIRECT(Sheet1!$A$1)

This will of course require that the values in A1 and the named ranges are perfect matches. Whenever the value in A1 is changed, the dynamic image will change as well. Here is a screenshot of such a scenario with three different images.

So, before the form is loaded, or while the form is loading, you need to have some activity that sets cell A1 to the desired country name.

Answer 2

Never mind I figured it out.

Since Excel VBA wouldn't allow me to import PNG images without a background to seems as round, I just edited the background color in Photoshop to match the color of the User Interface.

Now once I import it it seems as though the image background is transparent and hence appears round.