Embedded gif in userform

[jazznaura]

Hi All,


I wish to show an embedded gif file (animation) in a userform. Below is whatI’ve tried with no success.

Need to use the embedded gif file in sheet 'MenuSh' as workbook will be sent out to work colleagues who will not have the original gif file. Possible or another way?


Help please

[vba]Private Sub UserForm_Initialize()
WebBrowser1.Navigate MenuSh.OLEObjects(1)
DoEvents
WebBrowser1.Document.Body.Scroll = "no"
WebBrowser1.Document.Body.Style.BorderStyle = "none"
End Sub[/vba]

thanks,

jazznaura.

[p45cal]

Not sure about animated gif files, never tried, but you can put a gif file as the picture. If you click on the Picture property of the userform, you'll get an ellipsis ( a … ) on a button where you'll be able to navigate to the gif file. The gif gets saved with the workbook, so there's no need for users to have access to the gif file on a network somewhere,

[jazznaura]

thanks for the reply p45cal but really need to get that gif running in the webbrowser if poss. i can do it if its saved on a hard drive somewhere..... just can't figure out how to, if its embedded.

or maybe swf player ? anyone.

[Zack Barresse]

Using a webbrowser control should work for you. I generally stay away from them because there's very little options as far as formatting it, so the gif should be sized appropriately already. But yes, that will work, so long as (assuming it's on the internet) everyone has access.

AFAIK a Picture object does not support animated gif's, and while it can show the picture, it will not animate (going from memory here).

You could use flash, but I think it would be way more work than required. Plus you'd have to reference controls you'd need to ensure everyone had installed, and that in itself could be a nightmare. Best to use the web browser control, or be content with a non-animated file.

You could also, as a workaround, have multiple pictures which are housed in the file itself, and just load the picture at different time intervals, but it would probably be a messy workaround as well.

HTH

[jazznaura]

thanks Zack, think i'll have to go with the below.

You could also, as a workaround, have multiple pictures which are housed in the file itself, and just load the picture at different time intervals, but it would probably be a messy workaround as well.

[Zack Barresse]

It is a little tricky to do so, and is easier done from a saved data source. However, if you want to use pictures in your file, you could use something like this...

userform initialize event
[vba]Option Explicit

Private Sub UserForm_Initialize()

Dim PictureWKS As Worksheet
Dim oShp As Shape
Dim sPicName As String
Dim sPicFullname As String
Const TempPath As String = "C:\Users\Zack\Desktop\" 'must have permissions to read/write here, change as desired (it's only temporary)
Const FileFormat As String = "bmp" 'needs to be a recognized file format

On Error Resume Next
Err.Clear
Set PictureWKS = ThisWorkbook.Worksheets("Input") ' - set worksheet housing picture here
Set oShp = PictureWKS.Shapes("Picture 1") ' - set picture object/name here
If Err.Number <> 0 Then
'could not resolve objects
Exit Sub
End If

sPicName = oShp.Name
sPicFullname = TempPath & sPicName & "." & FileFormat

'save picture locally
SaveObjectPictureToFile oShp, sPicFullname, oShp.Width, oShp.Height

If Dir(sPicFullname, vbNormal) = vbNullString Then
'file doesn't exist
Exit Sub
End If

'load picture
Image1.Picture = LoadPicture(sPicFullname, oShp.Width, oShp.Height)

'delete picture
Kill sPicFullname

End Sub[/vba]

In a standard module
This was modified from someone else's previous work
[vba]Option Explicit

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyImage Lib "user32" (ByVal hImage As Long, ByVal uType As Long, ByVal PixelWidth As Long, ByVal PixelHeight As Long, ByVal Flags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pPictDesc As PictDesc, riid As Guid, ByVal fOwn As Long, ppvObj As IPicture) As Long

Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type

Private Const BLOCK_SIZE = 16384
Private Const CF_BITMAP = 2
Private Const S_OK As Long = &H0
Private Const LR_COPYRETURNORG = &H4

Function IPictureFromCopyPicture(Source As Object, Optional StretchWidth As Single, Optional StretchHeight As Single) As IPictureDisp
Dim hBmp As Long
Dim PictDesc As PictDesc
Dim IDispatch As Guid
Dim SaveWidth As Single
Dim SaveHeight As Single
Dim PicIsRng As Boolean

If StretchWidth <> 0 Or StretchHeight <> 0 Then
If TypeOf Source Is Range Then
Source.CopyPicture
ActiveSheet.PasteSpecial "Picture (Enhanced Metafile)"
Set Source = Selection
PicIsRng = True
End If

SaveWidth = Source.Width
SaveHeight = Source.Height
Source.Width = IIf(StretchWidth = 0, Source.Width, StretchWidth)
Source.Height = IIf(StretchHeight = 0, Source.Height, StretchHeight)
Source.CopyPicture xlScreen, xlBitmap

If PicIsRng Then
Source.Delete
Else
Source.Width = SaveWidth
Source.Height = SaveHeight
End If
Else
Source.CopyPicture xlScreen, xlBitmap
End If
If OpenClipboard(0) <> 0 Then
hBmp = GetClipboardData(CF_BITMAP)
hBmp = CopyImage(hBmp, 0, 0, 0, LR_COPYRETURNORG)
CloseClipboard
If hBmp <> 0 Then

With IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

With PictDesc
.cbSizeofStruct = Len(PictDesc)
.picType = 1
.hImage = hBmp
End With

If OleCreatePictureIndirect(PictDesc, IDispatch, False, IPictureFromCopyPicture) <> S_OK Then
Set IPictureFromCopyPicture = Nothing
End If
End If
End If
End Function


Function SaveObjectPictureToFile(ByVal Source As Object, FileName As String, Optional StretchWidth As Single, Optional StretchHeight As Single) As Boolean
Dim Ipic As IPictureDisp

Set Ipic = IPictureFromCopyPicture(Source, StretchWidth, StretchHeight)
If Not Ipic Is Nothing Then
On Error Resume Next
Err.Clear
SavePicture Ipic, FileName
On Error GoTo 0
If Err.Number <> 0 Then
'did not save, insufficient permissions
SaveObjectPictureToFile = False
Else
SaveObjectPictureToFile = True
End If
End If
End Function[/vba]

[Zack Barresse]

Hmm, I just realized I didn't make amendments to the code for an actual animation event. The following code will do that.

[vba]Option Explicit

Dim Animated As Boolean

Private Sub UserForm_Activate()
Animated = True
Call AnimateMe
End Sub

Private Sub AnimateMe()

Dim PictureWKS As Worksheet
Dim oShp As Shape
Dim sPicName As String
Dim sPicFullname As String
Dim iPictureNumber As Long
Dim iTime As Double
Dim iStep As Long
Dim aPictures() As Variant
Dim iMinStep As Long
Dim iMaxStep As Long

Const TempPath As String = "C:\Users\Zack\Desktop\" 'must have permissions to read/write here
Const sFileFormat As String = "bmp" 'needs to be a recognized file format
Const iTimeInterval As Double = 1 'set as desired interval

aPictures = Array("Picture 1", "Picture 2") 'set array of pictures names, assumes all are on the same sheet
iMinStep = LBound(aPictures)
iMaxStep = UBound(aPictures)

On Error Resume Next
Err.Clear
Set PictureWKS = ThisWorkbook.Worksheets("Input") ' - set worksheet housing picture here

DoEvents
iTime = Timer
iStep = 1

Do While Animated

Set oShp = PictureWKS.Shapes(aPictures(iPictureNumber)) ' - set picture object here
If Err.Number <> 0 Then
'could not resolve objects
Exit Sub
End If
sPicName = oShp.Name
sPicFullname = TempPath & sPicName & "." & sFileFormat
'save picture locally
SaveObjectPictureToFile oShp, sPicFullname, oShp.Width, oShp.Height
If Dir(sPicFullname, vbNormal) = vbNullString Then
'file doesn't exist
Exit Sub
End If
'load picture
Image1.Picture = LoadPicture(sPicFullname, oShp.Width, oShp.Height)
'delete picture
Kill sPicFullname

Do While Timer - iTime < iTimeInterval
Loop
If iPictureNumber = iMaxStep Then
iPictureNumber = iMinStep
Else
iPictureNumber = iPictureNumber + 1
End If

iTime = Timer
DoEvents

Loop

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Animated = False
End Sub[/vba]

Please note that while the picture loads the userform will be unavailable, so it will look like the form is slow or glitchy. I'm not entirely sure what could be done to improve upon this. The reason is because we're taking the picture from your worksheet and saving it temporarily, then using that to load into a userform image control. If you had the images stored locally already it wouldn't be a problem as much.

If the code gets to a picture in the array aPictures() that it can't find, it will hang on the last valid image found.

HTH