chart as a splash screen / popup

[Cossie]

I have a chart in a workbook that i want to make appear when you hit a command button, stay for 10 seconds and then disappear.

Any suggestions would be welcome?

[Mark O'Brien]

OK, this is going to be a long post.

What you need.

1. A userform called (mine's called Userform1) with an Image control on it, mine's called Image1.
2. A chart on the active worksheet (mine's called "Chart 2"
3. A button on the worksheet that runs the code to show the userform, i.e. the click event has this code:

 UserForm1.Show

4. A standard code module.

OK, in the standard module copy and paste this code:

'***************************************************************************

'*

'* MODULE NAME:     Paste Picture

'* AUTHOR & DATE:   STEPHEN BULLEN, Business Modelling Solutions Ltd.

'*                  15 November 1998

'*

'* CONTACT:         Stephen@BMSLtd.co.uk

'* WEB SITE:        http://www.BMSLtd.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 a UDT to store a GUID 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 a UDT to store the bitmap information

Private Type uPicDesc

    Size As Long

    Type As Long

    hPic As Long

    hPal As Long

End Type



'''Windows API Function Declarations



'Does the clipboard contain a bitmap/metafile?

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long



'Open the clipboard to read

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long



'Get a pointer to the bitmap/metafile

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long



'Close the clipboard

Private Declare Function CloseClipboard Lib "user32" () As Long



'Convert the handle into an OLE IPicture interface.

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic 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" 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" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long



'The API format types we're interested in

Const CF_BITMAP = 2

Const CF_PALETTE = 9

Const CF_ENHMETAFILE = 14

Const IMAGE_BITMAP = 0

Const LR_COPYRETURNORG = &H4



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''' Subroutine: PastePicture

'''

''' Purpose:    Get a Picture object showing whatever's on the clipboard.

'''

''' Arguments:  lXlPicType - The type of picture to create.  Can be one of:

'''                          xlPicture to create a metafile (default)

'''                          xlBitmap to create a bitmap

'''

''' Date        Developer           Action

''' --------------------------------------------------------------------------

''' 30 Oct 98   Stephen Bullen      Created

''' 15 Nov 98   Stephen Bullen      Updated to create our own copies of the clipboard images

'''



Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture



'Some pointers

Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long



'Convert the type of picture requested from the xl constant to the API constant

lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)



'Check if the clipboard contains the required format

hPicAvail = IsClipboardFormatAvailable(lPicType)



If hPicAvail <> 0 Then

    'Get access to the clipboard

    h = OpenClipboard(0&)



    If h > 0 Then

        'Get a handle to the image data

        hPtr = GetClipboardData(lPicType)



        'Create our own copy of the image on the clipboard, in the appropriate format.

        If lPicType = CF_BITMAP Then

            hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)

        Else

            hCopy = CopyEnhMetaFile(hPtr, vbNullString)

        End If



        'Release the clipboard to other programs

        h = CloseClipboard



        'If we got a handle to the image, convert it into a Picture object and return it

        If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)

    End If

End If



End Function





''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''' Subroutine: CreatePicture

'''

''' Purpose:    Converts a image (and palette) handle into a Picture object.

'''

'''             Requires a reference to the "OLE Automation" type library

'''

''' Arguments:  None

'''

''' Date        Developer           Action

''' --------------------------------------------------------------------------

''' 30 Oct 98  Stephen Bullen      Created

'''



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



' IPicture requires a reference to "OLE Automation"

Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture



'OLE Picture types

Const PICTYPE_BITMAP = 1

Const PICTYPE_ENHMETAFILE = 4



' Create the Interface GUID (for the IPicture interface)

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



' Fill uPicInfo with necessary parts.

With uPicInfo

    .Size = Len(uPicInfo)                                                   ' Length of structure.

    .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)  ' Type of Picture

    .hPic = hPic                                                            ' Handle to image.

    .hPal = IIf(lPicType = CF_BITMAP, hPal, 0)                              ' Handle to palette (if bitmap).

End With



' Create the Picture object.

r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)



' If an error occured, show the description

If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)



' Return the new Picture object.

Set CreatePicture = IPic



End Function



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

''' Subroutine: fnOLEError

'''

''' Purpose:    Gets the message text for standard OLE errors

'''

''' Arguments:  None

'''

''' Date        Developer           Action

''' --------------------------------------------------------------------------

''' 30 Oct 98   Stephen Bullen      Created

'''



Private Function fnOLEError(lErrNum 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

Const S_OK = &H0



Select Case lErrNum

Case E_ABORT

    fnOLEError = " Aborted"

Case E_ACCESSDENIED

    fnOLEError = " Access Denied"

Case E_FAIL

    fnOLEError = " General Failure"

Case E_HANDLE

    fnOLEError = " Bad/Missing Handle"

Case E_INVALIDARG

    fnOLEError = " Invalid Argument"

Case E_NOINTERFACE

    fnOLEError = " No Interface"

Case E_NOTIMPL

    fnOLEError = " Not Implemented"

Case E_OUTOFMEMORY

    fnOLEError = " Out of Memory"

Case E_POINTER

    fnOLEError = " Invalid Pointer"

Case E_UNEXPECTED

    fnOLEError = " Unknown Error"

Case S_OK

    fnOLEError = " Success!"

End Select



End Function

On the userform, put this code:

Private Sub UserForm_Activate()

  Application.Wait Now + TimeValue("0:00:10")

  Unload Me

End Sub



Private Sub UserForm_Initialize()

  ActiveSheet.Shapes("Chart 2").CopyPicture

  Me.Image1.Picture = PastePicture

End Sub

OK, that's all you need. Click your button and the form should show with the graph on the image control. If you need to get rid of the title bar on the userform, search this board. If you can't find it just repost.

HTH

And if there's any problems, just repost. (Oh yeah, to get the graph to automatically size to fit the Image control, go into the code version of the USerform and click on the Image control, hit "F4" to get the properties window up. Scroll down in the properties window and find the property called "PictureSizeMode" set this to option 1, "fmPictureSizeModeStretch")

Phew!

[Cossie]

Mark

that was a mammoth effort Thanks for the time you took to put that together.

The only problem so far is that it stops at "chart 2"

Private Sub UserForm_Initialize()
ActiveSheet.Shapes("Chart 2").CopyPicture
Me.Image1.Picture = PastePicture
End Sub

Is there something i am doing wrong?
this site is awesome!!

[Mark O'Brien]

You need to change "Chart 2" to whatever the name of your chart is.

To find out hold down CTRL and Click on your graph. The combo box to the left of the formula bar will show the name of the chart.

PS. The original post only took 10 minutes to knock together. I've had to do something similar before.

[Ivan F Moala]

On 2002-05-09 17:25, Cossie wrote:
I have a chart in a workbook that i want to make appear when you hit a command button, stay for 10 seconds and then disappear.

Any suggestions would be welcome?

Hi Cossie
Not to take away from Mark but another
easier option is to just make your chart
visible/Not Visible via the command button ?
The Chart after all is just an Object and most excel objects have the Visible property.


If you know the name of the Chart then;

Sub showChart()

Dim Ch As Object



'//Change [Chart 1] to the name of your Chart

Set Ch = ActiveSheet.Shapes("Chart 1")



Ch.Visible = Not (Ch.Visible)

    DoEvents

    Application.Wait Now + TimeValue("00:00:10")

Ch.Visible = Not (Ch.Visible)



Set Ch = Nothing

End Sub

[Cossie]

Thanks Ivan

The code runs, but the chart remains visible the whole time.

Do i need to do something else.

Thnaks for your assistance

[Ivan F Moala]

On 2002-05-12 17:05, Cossie wrote:
Thanks Ivan

The code runs, but the chart remains visible the whole time.

Do i need to do something else.

Thnaks for your assistance

try this;

Sub showChart()
Dim Ch As Object

'//Change [Chart 1] to the name of your Chart
Set Ch = ActiveSheet.Shapes("Chart 1")

Ch.Visible = True
DoEvents
Application.Wait Now + TimeValue("00:00:10")
Ch.Visible = False

Set Ch = Nothing
End Sub

[Cossie]

Ivan

That runs the code and i get a flash of the chart at the end - but not for 10 seconds more like less than 1 sec.

thanks for you assistance