PictureData to StdPicture

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 FPictureDatatoStdPicture (far below). The
code errors out with invalid picture on the following line of code:

imgX.ListImages.Add , Key:=rst("key"), Picture:=objPicture


Any ideas... most of the code was borrowed from the lebans website. I
believe what I need is a PictureDatatoStdPicture 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.Visible = True
Set imgX = Me.ImgList.Object
imgX.ListImages.Clear
Set imgY = Me.ImageList6.Object
imgY.ListImages.Clear


'On Error GoTo SetImgListErr
Set rst = CurrentDb.OpenRecordset("icons")
If rst.RecordCount <> 0 Then
Do While Not rst.EOF
AccessImage.PictureData = rst("picturedata")
PictureData = rst("picturedata")
Set objPicture = FPictureDataToStdPicture(PictureData)
imgX.ListImages.Add , Key:=rst("key"), Picture:=objPicture
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 FPictureDataToStdPicture(PictureData 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(PictureData) - 1)
APGDebug "Len of PictureData=" & (LenB(PictureData) - 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(GMEM_MOVEABLE Or GMEM_SHARE Or
GMEM_ZEROINIT, UBound(bArray) + 1)
If hGlobalMemory = 0 Then _
Err.Raise vbObjectError + 515, "ImageToClipBoard.modImageToClipBoard",
_
"GlobalAlloc Failed..not enough memory"

' Lock this block to get a pointer we can use to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
If lpGlobalMemory = 0 Then _
Err.Raise vbObjectError + 516, "ImageToClipBoard.modImageToClipBoard",
_
"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(hGlobalMemory) <> 0 Then _
Err.Raise vbObjectError + 517, "ImageToClipBoard.modImageToClipBoard",
_
"GlobalUnLock Failed"


Case CF_ENHMETAFILE
' New Enhanced Metafile(EMF)
CBFormat = CF_ENHMETAFILE
hMetafile = SetEnhMetaFileBits(UBound(bArray) + 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 = SetWinMetaFileBits(UBound(bArray) + 24 + 1 - 8, bArray(24),
0&, cfm)


Case Else
'Should not happen
Err.Raise vbObjectError + 514, "ImageToClipBoard.modImageToClipBoard",
_
"Unrecognized PictureData ClipBoard format"

End Select

' Can we open the ClipBoard.
If OpenClipboard(0&) = 0 Then _
Err.Raise vbObjectError + 518, "ImageToClipBoard.modImageToClipBoard",
_
"OpenClipBoard 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 = SetClipboardData(CF_ENHMETAFILE, hMetafile)

picdes.Size = Len(picdes)
picdes.type = vbPicTypeEMetafile
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.Data1 = &H7BF80980
iidIPicture.Data2 = &HBF32
iidIPicture.Data3 = &H101A
iidIPicture.Data4(0) = &H8B
iidIPicture.Data4(1) = &HBB
iidIPicture.Data4(2) = &H0
iidIPicture.Data4(3) = &HAA
iidIPicture.Data4(4) = &H0
iidIPicture.Data4(5) = &H30
iidIPicture.Data4(6) = &HC
iidIPicture.Data4(7) = &HAB
'' Create picture from bitmap handle
lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
'' Result will be valid Picture or Nothing-either way set it
Set FPictureDataToStdPicture = IPic




Else
'' We are dealing with a standard DIB.
hClipMemory = SetClipboardData(CBFormat, hGlobalMemory)

End If



Exit_PtoC:
Exit Function


Err_PtoC:
Set FPictureDataToStdPicture = Nothing
APGDebug Err.Description & Err.Source & ":" & Err.Number
Resume Exit_PtoC

End Function

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.IPictureDisp
set pic = SysCmd(712,NameofYourImageControlHere)

--

HTH
Stephen Lebans
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.googlegr oups.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 FPictureDatatoStdPicture (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:=objPicture
>
>
> Any ideas... most of the code was borrowed from the lebans website. I
> believe what I need is a PictureDatatoStdPicture 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.Visible = True
> Set imgX = Me.ImgList.Object
> imgX.ListImages.Clear
> Set imgY = Me.ImageList6.Object
> imgY.ListImages.Clear
>
>
> 'On Error GoTo SetImgListErr
> Set rst = CurrentDb.OpenRecordset("icons")
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
> AccessImage.PictureData = rst("picturedata")
> PictureData = rst("picturedata")
> Set objPicture = FPictureDataToStdPicture(PictureData)
> imgX.ListImages.Add , Key:=rst("key"), Picture:=objPicture
> 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 FPictureDataToStdPicture(PictureData 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(PictureData) - 1)
> APGDebug "Len of PictureData=" & (LenB(PictureData) - 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(GMEM_MOVEABLE Or GMEM_SHARE Or
> GMEM_ZEROINIT, UBound(bArray) + 1)
> If hGlobalMemory = 0 Then _
> Err.Raise vbObjectError + 515, "ImageToClipBoard.modImageToClipBoard",
> _
> "GlobalAlloc Failed..not enough memory"
>
> ' Lock this block to get a pointer we can use to this memory.
> lpGlobalMemory = GlobalLock(hGlobalMemory)
> If lpGlobalMemory = 0 Then _
> Err.Raise vbObjectError + 516, "ImageToClipBoard.modImageToClipBoard",
> _
> "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(hGlobalMemory) <> 0 Then _
> Err.Raise vbObjectError + 517, "ImageToClipBoard.modImageToClipBoard",
> _
> "GlobalUnLock Failed"
>
>
> Case CF_ENHMETAFILE
> ' New Enhanced Metafile(EMF)
> CBFormat = CF_ENHMETAFILE
> hMetafile = SetEnhMetaFileBits(UBound(bArray) + 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 = SetWinMetaFileBits(UBound(bArray) + 24 + 1 - 8,[/color]
bArray(24),[color=blue]
> 0&, cfm)
>
>
> Case Else
> 'Should not happen
> Err.Raise vbObjectError + 514, "ImageToClipBoard.modImageToClipBoard",
> _
> "Unrecognized PictureData ClipBoard format"
>
> End Select
>
> ' Can we open the ClipBoard.
> If OpenClipboard(0&) = 0 Then _
> Err.Raise vbObjectError + 518, "ImageToClipBoard.modImageToClipBoard",
> _
> "OpenClipBoard 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 = SetClipboardData(CF_ENHMETAFILE, hMetafile)
>
> picdes.Size = Len(picdes)
> picdes.type = vbPicTypeEMetafile
> 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.Data1 = &H7BF80980
> iidIPicture.Data2 = &HBF32
> iidIPicture.Data3 = &H101A
> iidIPicture.Data4(0) = &H8B
> iidIPicture.Data4(1) = &HBB
> iidIPicture.Data4(2) = &H0
> iidIPicture.Data4(3) = &HAA
> iidIPicture.Data4(4) = &H0
> iidIPicture.Data4(5) = &H30
> iidIPicture.Data4(6) = &HC
> iidIPicture.Data4(7) = &HAB
> '' Create picture from bitmap handle
> lngRet = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
> '' Result will be valid Picture or Nothing-either way set it
> Set FPictureDataToStdPicture = IPic
>
>
>
>
> Else
> '' We are dealing with a standard DIB.
> hClipMemory = SetClipboardData(CBFormat, hGlobalMemory)
>
> End If
>
>
>
> Exit_PtoC:
> Exit Function
>
>
> Err_PtoC:
> Set FPictureDataToStdPicture = Nothing
> APGDebug Err.Description & Err.Source & ":" & Err.Number
> Resume Exit_PtoC
>
> End Function
>[/color]

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_AfterUpdate. 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_AfterUpdate()
Dim rst As Recordset
Dim qry As QueryDef

Set qry = CurrentDb.QueryDefs("GetIcon")
qry.parameters("param1") = Nz(Me!Combo80, "invis") ' use blank icon if
we can't find anything
Set rst = qry.OpenRecordset
If rst.RecordCount <> 0 Then
Do While Not rst.EOF
Me.Image79.PictureData = rst("picturedata")
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("ControlReference") Then
DoCmd.OpenForm "ControlReference"
Forms!ControlReference.Visible = False
End If
If IsLoaded("ControlReference") Then

gotFile = VBGetOpenFileName(filename:=striconame, InitDir:=DBPath)

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

If extension = "ico" Then

fStdPicToImageData hStdPic:=LoadPicture(striconame), ctl:=Me.Image75

Set rs = CurrentDb.OpenRecordset("icons")
rs.AddNew
rs("picturedata") = Me.Image75.PictureData
APGDebug (filename)
rs("key") = filename
rs("tag") = filename
rs.Update
rs.Close
Me.Combo71.Requery
Me.Combo77.Requery
Me.Combo80.Requery

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.IPictureDisp
'AccessImage.Visible = True
Set imgX = Me.ImgList.Object
imgX.ListImages.Clear
Set imgY = Me.ImageList6.Object
imgY.ListImages.Clear


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

Me.Image77.PictureData = rst("picturedata")
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.QueryDefs("GetIcon")
qry.parameters("param1") = Nz(Me!Combo80, "invis")
Set rst = qry.OpenRecordset
If rst.RecordCount <> 0 Then
Do While Not rst.EOF
Me.Image79.PictureData = rst("picturedata")
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.IPictureDisp
'AccessImage.Visible = True
Set imgX = Me.ImgList.Object
imgX.ListImages.Clear
Set imgY = Me.ImageList6.Object
imgY.ListImages.Clear


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

Me.Image77.PictureData = rst("picturedata")
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

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.


<trojacek@gmail.com> wrote in message
news:1105286560.921875.188100@c13g2000cwb.googlegr oups.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_AfterUpdate. 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_AfterUpdate()
> Dim rst As Recordset
> Dim qry As QueryDef
>
> Set qry = CurrentDb.QueryDefs("GetIcon")
> qry.parameters("param1") = Nz(Me!Combo80, "invis") ' use blank icon if
> we can't find anything
> Set rst = qry.OpenRecordset
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
> Me.Image79.PictureData = rst("picturedata")
> 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("ControlReference") Then
> DoCmd.OpenForm "ControlReference"
> Forms!ControlReference.Visible = False
> End If
> If IsLoaded("ControlReference") Then
>
> gotFile = VBGetOpenFileName(filename:=striconame, InitDir:=DBPath)
>
> If gotFile Then
> If Len(striconame) <> 0 Then
> extension = Right(striconame, 3)
> pathname = Left(striconame, InStrRev(striconame, "\"))
> iconame = Split(filename, ".")
> filename = Right(striconame, Len(striconame) - Len(pathname))
> 'strip extension
> filename = Left(filename, InStr(1, filename, ".") - 1)
>
> If extension = "ico" Then
>
> fStdPicToImageData hStdPic:=LoadPicture(striconame), ctl:=Me.Image75
>
> Set rs = CurrentDb.OpenRecordset("icons")
> rs.AddNew
> rs("picturedata") = Me.Image75.PictureData
> APGDebug (filename)
> rs("key") = filename
> rs("tag") = filename
> rs.Update
> rs.Close
> Me.Combo71.Requery
> Me.Combo77.Requery
> Me.Combo80.Requery
>
> 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.IPictureDisp
> 'AccessImage.Visible = True
> Set imgX = Me.ImgList.Object
> imgX.ListImages.Clear
> Set imgY = Me.ImageList6.Object
> imgY.ListImages.Clear
>
>
> 'On Error GoTo SetImgListErr
> Set rst = CurrentDb.OpenRecordset("icons")
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
>
> Me.Image77.PictureData = rst("picturedata")
> 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.QueryDefs("GetIcon")
> qry.parameters("param1") = Nz(Me!Combo80, "invis")
> Set rst = qry.OpenRecordset
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
> Me.Image79.PictureData = rst("picturedata")
> 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.IPictureDisp
> 'AccessImage.Visible = True
> Set imgX = Me.ImgList.Object
> imgX.ListImages.Clear
> Set imgY = Me.ImageList6.Object
> imgY.ListImages.Clear
>
>
> 'On Error GoTo SetImgListErr
> Set rst = CurrentDb.OpenRecordset("icons")
> If rst.RecordCount <> 0 Then
> Do While Not rst.EOF
>
> Me.Image77.PictureData = rst("picturedata")
> 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]