PictureData to StdPicture

**Stephen Lebans** · Nov 13 '05, 07:05 AM

Re: PictureData to StdPicture

You need to clarify exactly what you are trying to do here. You state
that you need to process the data from an OLE field but then you try to
shove this data into the PictureData prop of an Image control not an OLE
Frame control.
How was the data stored in the OLE field? What exactly is the format of
the data?

If you have a valid PictureData prop then there is a SysCmd method
available that will return a StdPicture interface from the contents of
an Image control.

Dim pic As stdole.IPicture Disp
set pic = SysCmd(712,Name ofYourImageCont rolHere)

--

HTH
Stephen Lebans

Lebans.com

http://www.lebans.com

Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.

<trojacek@gmail .com> wrote in message
news:1105224914 .826294.244390@ c13g2000cwb.goo glegroups.com.. .[color=blue]
> I'm trying to load image data stored in an OLE field into an image
> list, that will be used by a treeview to show icons. This is at run
> time.
>
> To do this, I'm trying to load the field which contains the[/color]
picturedata[color=blue]
> into my image list by using a function that converts the picturedata
> into what I believe is a stdpicture.
>
> The Access errors out with "invalid picture".
>
> When I look at the actual objPicture while debugging, it shows the
> image height and width to be 847 by 847, which makes me believe at
> least part of the code is working.
>
> The function SetImgList calls FPictureDatatoS tdPicture (far below).[/color]
The[color=blue]
> code errors out with invalid picture on the following line of code:
>
> imgX.ListImages .Add , Key:=rst("key") , Picture:=objPic ture
>
>
> Any ideas... most of the code was borrowed from the lebans website. I
> believe what I need is a PictureDatatoSt dPicture function that[/color]
actually[color=blue]
> works or a better understanding for the types of objects that an
> imagelist can load. I've been struggling with this for two weeks now[/color]
so[color=blue]
> any help would be greatly appreciated..
>
>
> Public Function SetImgList()
> Dim imgX, imgY As Object
> Dim objPicture As StdPicture
> Dim icoPicture As StdPicture
> Dim rst As Recordset
> Dim objPic As Object
> Dim PictureData As Variant
> Dim handle, handle2 As Long
> Dim AccessImage As Access.image
> Dim ipd As IPictureDisp
> Set AccessImage = Me.Image77
> AccessImage.Vis ible = True
> Set imgX = Me.ImgList.Obje ct
> imgX.ListImages .Clear
> Set imgY = Me.ImageList6.O bject
> imgY.ListImages .Clear
>
>
> 'On Error GoTo SetImgListErr
> Set rst = CurrentDb.OpenR ecordset("icons ")
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
> AccessImage.Pic tureData = rst("picturedat a")
> PictureData = rst("picturedat a")
> Set objPicture = FPictureDataToS tdPicture(Pictu reData)
> imgX.ListImages .Add , Key:=rst("key") , Picture:=objPic ture
> rst.MoveNext
> Loop
> Set objPicture = Nothing
> Set icoPicture = Nothing
> rst.Close
> End If
> Set rst = Nothing
> Set imgX = Nothing
> GoTo Done
> SetImgListErr:
> APGDebug (Err.Number & " " & Err.Description )
> Done:
> End Function
>
>
>
> Function FPictureDataToS tdPicture(Pictu reData As Variant) As IPicture
> ' Memory Vars
> Dim hGlobalMemory As Long
> Dim lpGlobalMemory As Long
> Dim hClipMemory As Long
>
> 'Fill picture description
> Dim lngRet As Long
> Dim IPic As IPicture, picdes As PictDesc, iidIPicture As IID
>
>
> ' Cf_metafilepict structure
> Dim cfm As MetaFilePict
>
> ' Handle to a Memory Metafile
> Dim hMetafile As Long
>
> ' Which ClipBoard format is contained in the PictureData prop
> Dim CBFormat As Long
>
> ' Byte array to hold the PictureData prop
> Dim bArray() As Byte
>
> ' Temp var
>
>
> 'On Error GoTo Err_PtoC
>
> ' Resize to hold entire PictureData prop
> ReDim bArray(LenB(Pic tureData) - 1)
> APGDebug "Len of PictureData=" & (LenB(PictureDa ta) - 1)
> ' Copy to our array
> bArray = PictureData
>
> ' Determine which ClipBoard format we are using
> Select Case bArray(0)
>
>
> Case 40
> ' This is a straight DIB.
> CBFormat = CF_DIB
> ' MSDN states to Allocate moveable|Shared Global memory
> ' for ClipBoard operations.
> hGlobalMemory = GlobalAlloc(GME M_MOVEABLE Or GMEM_SHARE Or
> GMEM_ZEROINIT, UBound(bArray) + 1)
> If hGlobalMemory = 0 Then _
> Err.Raise vbObjectError + 515, "ImageToClipBoa rd.modImageToCl ipBoard",
> _
> "GlobalAllo c Failed..not enough memory"
>
> ' Lock this block to get a pointer we can use to this memory.
> lpGlobalMemory = GlobalLock(hGlo balMemory)
> If lpGlobalMemory = 0 Then _
> Err.Raise vbObjectError + 516, "ImageToClipBoa rd.modImageToCl ipBoard",
> _
> "GlobalLock Failed"
>
> ' Copy DIB as is in its entirety
> apiCopyMemory ByVal lpGlobalMemory, bArray(0), UBound(bArray) + 1
>
> ' Unlock the memory and then copy to the clipboard
> If GlobalUnlock(hG lobalMemory) <> 0 Then _
> Err.Raise vbObjectError + 517, "ImageToClipBoa rd.modImageToCl ipBoard",
> _
> "GlobalUnLo ck Failed"
>
>
> Case CF_ENHMETAFILE
> ' New Enhanced Metafile(EMF)
> CBFormat = CF_ENHMETAFILE
> hMetafile = SetEnhMetaFileB its(UBound(bArr ay) + 1 - 8, bArray(8))
>
>
> Case CF_METAFILEPICT
> ' Old Metafile format(WMF)
> CBFormat = CF_METAFILEPICT
> ' Copy the Metafile Header over to our Local Structure
> apiCopyMemory cfm, bArray(8), Len(cfm)
> ' Let's convert older WMF to EMF.
> ' Allows us to have a single solution for Metafiles.
> ' 24 is the number of bytes in the sum of the
> ' METAFILEPICT structure and the 8 byte ClipBoard Format struct.
> hMetafile = SetWinMetaFileB its(UBound(bArr ay) + 24 + 1 - 8,[/color]
bArray(24),[color=blue]
> 0&, cfm)
>
>
> Case Else
> 'Should not happen
> Err.Raise vbObjectError + 514, "ImageToClipBoa rd.modImageToCl ipBoard",
> _
> "Unrecogniz ed PictureData ClipBoard format"
>
> End Select
>
> ' Can we open the ClipBoard.
> If OpenClipboard(0 &) = 0 Then _
> Err.Raise vbObjectError + 518, "ImageToClipBoa rd.modImageToCl ipBoard",
> _
> "OpenClipBo ard Failed"
>
> ' Always empty the ClipBoard First. Not the friendliest thing
> ' to do if you have several programs interacting!
> Call EmptyClipboard
>
> ' Now set the Image to the ClipBoard
> If CBFormat = CF_ENHMETAFILE Or CBFormat = CF_METAFILEPICT Then
>
> ' Remember we can use this logic for both types of Metafiles
> ' because we converted the older WMF to the newer EMF.
> 'hClipMemory = SetClipboardDat a(CF_ENHMETAFIL E, hMetafile)
>
> picdes.Size = Len(picdes)
> picdes.type = vbPicTypeEMetaf ile
> picdes.hBmp = hMetafile
>
> ' No palette info here
> ' Everything is 24bit for now
>
> 'picdes.hPal = hPal
> ' ' Fill in magic IPicture GUID
> {7BF80980-BF32-101A-8BBB-00AA00300CAB}
> iidIPicture.Dat a1 = &H7BF80980
> iidIPicture.Dat a2 = &HBF32
> iidIPicture.Dat a3 = &H101A
> iidIPicture.Dat a4(0) = &H8B
> iidIPicture.Dat a4(1) = &HBB
> iidIPicture.Dat a4(2) = &H0
> iidIPicture.Dat a4(3) = &HAA
> iidIPicture.Dat a4(4) = &H0
> iidIPicture.Dat a4(5) = &H30
> iidIPicture.Dat a4(6) = &HC
> iidIPicture.Dat a4(7) = &HAB
> '' Create picture from bitmap handle
> lngRet = OleCreatePictur eIndirect(picde s, iidIPicture, True, IPic)
> '' Result will be valid Picture or Nothing-either way set it
> Set FPictureDataToS tdPicture = IPic
>
>
>
>
> Else
> '' We are dealing with a standard DIB.
> hClipMemory = SetClipboardDat a(CBFormat, hGlobalMemory)
>
> End If
>
>
>
> Exit_PtoC:
> Exit Function
>
>
> Err_PtoC:
> Set FPictureDataToS tdPicture = Nothing
> APGDebug Err.Description & Err.Source & ":" & Err.Number
> Resume Exit_PtoC
>
> End Function
>[/color]

**trojacek@gmail.com** · Nov 13 '05, 07:06 AM

Re: PictureData to StdPicture

Just in case this helps, my ultimate goal is to build an "icon chooser"
for a treeview control. There may be another solution when taking a
step back.

On to the code....

I had previously found that SysCmd command and tried it, but it
produces the same error message. Just for giggles, I've placed that
code below under SetImgListRev (renamed intentially to avoid confusion
in this thread). I tried it again at your suggestion and same error,
invalid picture.

I've been using "AddPicture " (below) to load the picturedata into the
OLE field in the first place. The files I am loading are icons, nothing
else at this stage.

I display the icons on a form using an image control using code similar
to Combo80_AfterUp date. This code works like a charm, so it looks like
I've at least got something valid in my OLE field.

Perhaps this situation is merely a limitation of the types of pictures
the imglist control can accept, or perhaps the imglist can't accept
images at run time?

Thanks, shohn

Private Sub Combo80_AfterUp date()
Dim rst As Recordset
Dim qry As QueryDef

Set qry = CurrentDb.Query Defs("GetIcon")
qry.parameters( "param1") = Nz(Me!Combo80, "invis") ' use blank icon if
we can't find anything
Set rst = qry.OpenRecords et
If rst.RecordCount <> 0 Then
Do While Not rst.EOF
Me.Image79.Pict ureData = rst("picturedat a")
rst.MoveNext
Loop
rst.Close
End If

Set qry = Nothing
Set rst = Nothing

End Sub

Sub AddPicture()
Dim imgX As ImageList
Dim striconame As String
Dim gotFile As Boolean
Dim pathname, extension, filename As String
Dim iconame As Variant
Dim objPicture As Object
Dim rs As Recordset

'On Error GoTo AddPictureError

If Not IsLoaded("Contr olReference") Then
DoCmd.OpenForm "ControlReferen ce"
Forms!ControlRe ference.Visible = False
End If
If IsLoaded("Contr olReference") Then

gotFile = VBGetOpenFileNa me(filename:=st riconame, InitDir:=DBPath )

If gotFile Then
If Len(striconame) <> 0 Then
extension = Right(striconam e, 3)
pathname = Left(striconame , InStrRev(strico name, "\"))
iconame = Split(filename, ".")
filename = Right(striconam e, Len(striconame) - Len(pathname))
'strip extension
filename = Left(filename, InStr(1, filename, ".") - 1)

If extension = "ico" Then

fStdPicToImageD ata hStdPic:=LoadPi cture(striconam e), ctl:=Me.Image75

Set rs = CurrentDb.OpenR ecordset("icons ")
rs.AddNew
rs("picturedata ") = Me.Image75.Pict ureData
APGDebug (filename)
rs("key") = filename
rs("tag") = filename
rs.Update
rs.Close
Me.Combo71.Requ ery
Me.Combo77.Requ ery
Me.Combo80.Requ ery

End If

End If
End If
End If

Exit Sub
AddPictureError :

APGDebug ("Err No:" & Err.Number & " " & Err.Description )

End Sub

Public Function SetImgList()
Dim imgX, imgY As Object
Dim objPicture As StdPicture
Dim icoPicture As StdPicture
Dim rst As Recordset
Dim objPic As Object
Dim PictureData As Variant
Dim handle, handle2 As Long
Dim AccessImage As Access.image
Dim ipd As stdOle.IPicture Disp
'AccessImage.Vi sible = True
Set imgX = Me.ImgList.Obje ct
imgX.ListImages .Clear
Set imgY = Me.ImageList6.O bject
imgY.ListImages .Clear

'On Error GoTo SetImgListErr
Set rst = CurrentDb.OpenR ecordset("icons ")
If rst.RecordCount <> 0 Then
Do While Not rst.EOF

Me.Image77.Pict ureData = rst("picturedat a")
Set ipd = SysCmd(712, Me.Image77)
imgX.ListImages .Add , Key:=rst("key") , Picture:=ipd
rst.MoveNext
Loop
Set ipd = Nothing
Set objPicture = Nothing
rst.Close
End If
Set rst = Nothing
Set imgX = Nothing
GoTo Done
SetImgListErr:
APGDebug (Err.Number & " " & Err.Description )
Done:
End Function

Private Sub LoadIcon()
Dim rst As Recordset
Dim qry As QueryDef

Set qry = CurrentDb.Query Defs("GetIcon")
qry.parameters( "param1") = Nz(Me!Combo80, "invis")
Set rst = qry.OpenRecords et
If rst.RecordCount <> 0 Then
Do While Not rst.EOF
Me.Image79.Pict ureData = rst("picturedat a")
rst.MoveNext
Loop
rst.Close
End If

Set qry = Nothing
Set rst = Nothing

End Sub

Public Function SetImgListRev()
Dim imgX, imgY As Object
Dim objPicture As StdPicture
Dim icoPicture As StdPicture
Dim rst As Recordset
Dim objPic As Object
Dim PictureData As Variant
Dim handle, handle2 As Long
Dim AccessImage As Access.image
Dim ipd As stdOle.IPicture Disp
'AccessImage.Vi sible = True
Set imgX = Me.ImgList.Obje ct
imgX.ListImages .Clear
Set imgY = Me.ImageList6.O bject
imgY.ListImages .Clear

'On Error GoTo SetImgListErr
Set rst = CurrentDb.OpenR ecordset("icons ")
If rst.RecordCount <> 0 Then
Do While Not rst.EOF

Me.Image77.Pict ureData = rst("picturedat a")
Set ipd = SysCmd(712, Me.Image77)
imgX.ListImages .Add , Key:=rst("key") , Picture:=ipd
rst.MoveNext
Loop
Set ipd = Nothing
Set objPicture = Nothing
rst.Close
End If
Set rst = Nothing
Set imgX = Nothing
GoTo Done
SetImgListErr:
APGDebug (Err.Number & " " & Err.Description )
Done:
End Function

**Stephen Lebans** · Nov 13 '05, 07:06 AM

Re: PictureData to StdPicture

Send me your MDB you are working with and I'll have a look at it for
you. My Email address is my first name @ my Domain name whihc
corresponds to my last name.

--

HTH
Stephen Lebans

Lebans.com

http://www.lebans.com

Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.

<trojacek@gmail .com> wrote in message
news:1105286560 .921875.188100@ c13g2000cwb.goo glegroups.com.. .[color=blue]
> Just in case this helps, my ultimate goal is to build an "icon[/color]
chooser"[color=blue]
> for a treeview control. There may be another solution when taking a
> step back.
>
> On to the code....
>
> I had previously found that SysCmd command and tried it, but it
> produces the same error message. Just for giggles, I've placed that
> code below under SetImgListRev (renamed intentially to avoid confusion
> in this thread). I tried it again at your suggestion and same error,
> invalid picture.
>
> I've been using "AddPicture " (below) to load the picturedata into the
> OLE field in the first place. The files I am loading are icons,[/color]
nothing[color=blue]
> else at this stage.
>
> I display the icons on a form using an image control using code[/color]
similar[color=blue]
> to Combo80_AfterUp date. This code works like a charm, so it looks like
> I've at least got something valid in my OLE field.
>
> Perhaps this situation is merely a limitation of the types of pictures
> the imglist control can accept, or perhaps the imglist can't accept
> images at run time?
>
> Thanks, shohn
>
>
> Private Sub Combo80_AfterUp date()
> Dim rst As Recordset
> Dim qry As QueryDef
>
> Set qry = CurrentDb.Query Defs("GetIcon")
> qry.parameters( "param1") = Nz(Me!Combo80, "invis") ' use blank icon if
> we can't find anything
> Set rst = qry.OpenRecords et
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
> Me.Image79.Pict ureData = rst("picturedat a")
> rst.MoveNext
> Loop
> rst.Close
> End If
>
> Set qry = Nothing
> Set rst = Nothing
>
> End Sub
>
>
>
>
> Sub AddPicture()
> Dim imgX As ImageList
> Dim striconame As String
> Dim gotFile As Boolean
> Dim pathname, extension, filename As String
> Dim iconame As Variant
> Dim objPicture As Object
> Dim rs As Recordset
>
> 'On Error GoTo AddPictureError
>
> If Not IsLoaded("Contr olReference") Then
> DoCmd.OpenForm "ControlReferen ce"
> Forms!ControlRe ference.Visible = False
> End If
> If IsLoaded("Contr olReference") Then
>
> gotFile = VBGetOpenFileNa me(filename:=st riconame, InitDir:=DBPath )
>
> If gotFile Then
> If Len(striconame) <> 0 Then
> extension = Right(striconam e, 3)
> pathname = Left(striconame , InStrRev(strico name, "\"))
> iconame = Split(filename, ".")
> filename = Right(striconam e, Len(striconame) - Len(pathname))
> 'strip extension
> filename = Left(filename, InStr(1, filename, ".") - 1)
>
> If extension = "ico" Then
>
> fStdPicToImageD ata hStdPic:=LoadPi cture(striconam e), ctl:=Me.Image75
>
> Set rs = CurrentDb.OpenR ecordset("icons ")
> rs.AddNew
> rs("picturedata ") = Me.Image75.Pict ureData
> APGDebug (filename)
> rs("key") = filename
> rs("tag") = filename
> rs.Update
> rs.Close
> Me.Combo71.Requ ery
> Me.Combo77.Requ ery
> Me.Combo80.Requ ery
>
> End If
>
>
> End If
> End If
> End If
>
> Exit Sub
> AddPictureError :
>
> APGDebug ("Err No:" & Err.Number & " " & Err.Description )
>
>
> End Sub
>
>
> Public Function SetImgList()
> Dim imgX, imgY As Object
> Dim objPicture As StdPicture
> Dim icoPicture As StdPicture
> Dim rst As Recordset
> Dim objPic As Object
> Dim PictureData As Variant
> Dim handle, handle2 As Long
> Dim AccessImage As Access.image
> Dim ipd As stdOle.IPicture Disp
> 'AccessImage.Vi sible = True
> Set imgX = Me.ImgList.Obje ct
> imgX.ListImages .Clear
> Set imgY = Me.ImageList6.O bject
> imgY.ListImages .Clear
>
>
> 'On Error GoTo SetImgListErr
> Set rst = CurrentDb.OpenR ecordset("icons ")
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
>
> Me.Image77.Pict ureData = rst("picturedat a")
> Set ipd = SysCmd(712, Me.Image77)
> imgX.ListImages .Add , Key:=rst("key") , Picture:=ipd
> rst.MoveNext
> Loop
> Set ipd = Nothing
> Set objPicture = Nothing
> rst.Close
> End If
> Set rst = Nothing
> Set imgX = Nothing
> GoTo Done
> SetImgListErr:
> APGDebug (Err.Number & " " & Err.Description )
> Done:
> End Function
>
>
>
> Private Sub LoadIcon()
> Dim rst As Recordset
> Dim qry As QueryDef
>
> Set qry = CurrentDb.Query Defs("GetIcon")
> qry.parameters( "param1") = Nz(Me!Combo80, "invis")
> Set rst = qry.OpenRecords et
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
> Me.Image79.Pict ureData = rst("picturedat a")
> rst.MoveNext
> Loop
> rst.Close
> End If
>
> Set qry = Nothing
> Set rst = Nothing
>
> End Sub
>
>
>
>
> Public Function SetImgListRev()
> Dim imgX, imgY As Object
> Dim objPicture As StdPicture
> Dim icoPicture As StdPicture
> Dim rst As Recordset
> Dim objPic As Object
> Dim PictureData As Variant
> Dim handle, handle2 As Long
> Dim AccessImage As Access.image
> Dim ipd As stdOle.IPicture Disp
> 'AccessImage.Vi sible = True
> Set imgX = Me.ImgList.Obje ct
> imgX.ListImages .Clear
> Set imgY = Me.ImageList6.O bject
> imgY.ListImages .Clear
>
>
> 'On Error GoTo SetImgListErr
> Set rst = CurrentDb.OpenR ecordset("icons ")
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
>
> Me.Image77.Pict ureData = rst("picturedat a")
> Set ipd = SysCmd(712, Me.Image77)
> imgX.ListImages .Add , Key:=rst("key") , Picture:=ipd
> rst.MoveNext
> Loop
> Set ipd = Nothing
> Set objPicture = Nothing
> rst.Close
> End If
> Set rst = Nothing
> Set imgX = Nothing
> GoTo Done
> SetImgListErr:
> APGDebug (Err.Number & " " & Err.Description )
> Done:
> End Function
>[/color]

PictureData to StdPicture

PictureData to StdPicture

Comment

Comment

Comment