PictureData to StdPicture

[trojacek]

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 picturedata
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). The
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 actually
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 so
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, bArray(24),
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

[Stephen Lebans]

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
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
<tr******@gmail .com> wrote in message
news:11******** **************@ c13g2000cwb.goo glegroups.com.. .

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 picturedata 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). The 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 actually 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 so 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, bArray(24), 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

[trojacek]

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]

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
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
<tr******@gmail .com> wrote in message
news:11******** **************@ c13g2000cwb.goo glegroups.com.. .

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