Affichage de photo (Binaire) dans un contrôle image [Résolu]

Messages postés
99
Date d'inscription
jeudi 17 janvier 2008
Statut
Membre
Dernière intervention
25 juillet 2013
- - Dernière réponse : cs_warzet
Messages postés
99
Date d'inscription
jeudi 17 janvier 2008
Statut
Membre
Dernière intervention
25 juillet 2013
- 31 janv. 2010 à 18:51
Bonjour à tous.
Je voudrais vs dire que je ne suis qu'un ptit débutant, autodictacte, aussi je souhaiterais avoir votre indulgence. Voici ma préoccupation actuelle.
J'ai écrit avce l'aide de vous tous le code ci-dessous pour sauvegarder une image dans une base Access en binaire ds champ Olé et ça marche. Mon problème, est que je n'arrive pas à récupérer l'image pour l'afficher dans la Frm.
Code Enrg:
'Déclaration d'une instance du recordset et ajout d'enregistrement
Set Stm = New ADODB.Stream
Set Rs = New ADODB.Recordset
Req = "select * From Personnels Where Matricule Like '" & TxtPers(4).Text & "'"
Rs.Open Req, Cnx, adOpenKeyset, adLockOptimistic, adCmdText

'vérification du doublons
If Rs!Matricule = TxtPers(4).Text Then
MsgBox "Le " & UCase(TxtGrade.Text) & " " & UCase(TxtPers(2).Text) & " " & UCase(TxtPers(3).Text) & vbCrLf & " Matricule : " & UCase(TxtPers(4).Text) & vbCrLf & " Est déjà Enregistré dans la Base DMIR", vbInformation
ViderCtrl
TxtPhoto.Caption = ""
Photo.Picture = Nothing
Exit Sub
End If

If Rs!Mecano = TxtPers(5).Text Then
MsgBox "Le " & UCase(TxtGrade.Text) & " " & UCase(TxtPers(2).Text) & " " & UCase(TxtPers(3).Text) & vbCrLf & " Matricule : " & UCase(TxtPers(4).Text) & vbCrLf & " Est déjà Enregistré dans la Base DMIR", vbInformation
ViderCtrl
TxtPhoto.Caption = ""
Photo.Picture = Nothing
Exit Sub
End If

Stm.Type = adTypeBinary
Stm.Open
Stm.LoadFromFile TxtPhoto.Caption
Rs.AddNew

Rs!NumPers = TxtPers.Item(0).Text
Rs!IdGrade = Trim(UCase(TxtPers.Item(1).Text))
Rs!Nom = Trim(UCase(TxtPers.Item(2).Text))
Rs!Prenom = Trim(UCase(TxtPers.Item(3).Text))
Rs!Matricule = Trim(UCase(TxtPers.Item(4).Text))
Rs!Mecano = Trim(UCase(TxtPers.Item(5).Text))
Rs!DateNais = TxtPers.Item(6).Text
Rs!RefLieu = Trim(UCase(TxtPers.Item(7).Text))
Rs!NomPere = Trim(UCase(TxtPers.Item(8).Text))
Rs!NomMere = Trim(UCase(TxtPers.Item(9).Text))
Rs!RefEthnie = Trim(UCase(TxtPers.Item(10).Text))
Rs!Taille = TxtPers.Item(11).Text
Rs!DateEntree = TxtPers.Item(12).Text
Rs!DatePromo = TxtPers.Item(13).Text
Rs!RefReligion = Trim(UCase(TxtPers.Item(14).Text))
Rs!GrpeSanguin = Trim(UCase(TxtPers.Item(15).Text))
Rs!RefSection = Trim(UCase(TxtPers.Item(16).Text))
Rs!RefNiveau = Trim(UCase(TxtPers.Item(17).Text))
Rs!RefSpe = Trim(UCase(TxtPers.Item(18).Text))
Rs!RefDiplome = Trim(UCase(TxtPers.Item(19).Text))
Rs!RefFonction = Trim(UCase(TxtPers.Item(20).Text))
Rs!Famille = Trim(UCase(TxtPers.Item(21).Text))
Rs!NbEnft = TxtPers.Item(22).Text
Rs!RefCorps = Trim(UCase(TxtPers.Item(23).Text))
Rs!RefCategorie = Trim(UCase(TxtPers.Item(24).Text))
Rs!DateEng = TxtPers.Item(25).Text
Rs!Surnom = Trim(UCase(TxtPers.Item(26).Text))
Rs!RefSitActuel = Trim(UCase(TxtPers.Item(27).Text))
Rs!Photo = UCase(TxtPhoto.Caption)
Rs!Photo1 = Stm.Read

Rs.Update
MsgBox "L'Enregistrement du " & UCase(TxtGrade.Text) & " " & UCase(TxtPers(2).Text) & " " & UCase(TxtPers(3).Text) & vbCrLf & " Matricule : " & UCase(TxtPers(4).Text) & vbCrLf & " a été Effectué avec succès", vbInformation

Rs.Close
Set Rs = Nothing
Set Stm = Nothing

ViderCtrl
TxtPhoto.Caption = ""
Photo.Picture = Nothing
CboGrade.SetFocus

Dans un Module:
Option Explicit
Dim sTemporyFileName As String

Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _
(ByVal LpszPath As String, ByVal LpPrefixString As String, ByVal wUnique As Long, _
ByVal LpTempFileName As String) As Long

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH = 260

et Ceci pour Récupérer l'image

Public Function GenerateTemporyFileName(Optional Prefix As String = "TMP") As String

Dim sBuffer As String
Dim sTempFolderPath As String

'Initialisation des Buffers
sTempFolderPath = String$(MAX_PATH, Chr$(0))
sBuffer = String$(MAX_PATH - 14, Chr$(0))

If GetTempPath(MAX_PATH, sTempFolderPath) Then
If GetTempFileName(sTempFolderPath, Prefix, 0&, sBuffer) Then
GenerateTemporyFileName = Left$(sBuffer, InStr(1, sBuffer, Chr$(0)) - 1)
End If
End If

End Function

Pour l'Affichage, je par d'un MsFlex comme ceci

Private Sub MsPers_Click()

On Error Resume Next
Set Stm = New ADODB.Stream
Set Rsd = New ADODB.Recordset
Req = "SELECT * FROM Personnel WHERE NumPers like '" & MsPers.Text & "'"
Rsd.Open Req, Cnx, adOpenKeyset, adLockOptimistic, adCmdText

Stm.Open
'Stm.Write Rsd.Fields("Photo1").Value

Rsd.MoveFirst

If Not IsNull(Rsd!NumPers) Then TxtPers.Item(0).Text = (Rsd!NumPers)
If Not IsNull(Rsd!Grade) Then CboGrade.Text = UCase(Rsd!Grade)
If Not IsNull(Rsd!Nom) Then TxtPers.Item(2).Text = UCase(Rsd!Nom)
If Not IsNull(Rsd!Prenom) Then TxtPers.Item(3).Text = UCase(Rsd!Prenom)
If Not IsNull(Rsd!Matricule) Then TxtPers.Item(4).Text = UCase(Rsd!Matricule)
If Not IsNull(Rsd!Mecano) Then TxtPers.Item(5).Text = UCase(Rsd!Mecano)
If Not IsNull(Rsd!DateNais) Then DateNais.Text = (Rsd!DateNais)
If Not IsNull(Rsd!NomLieu) Then CboLieu.Text = UCase(Rsd!NomLieu)
If Not IsNull(Rsd!NomPere) Then TxtPers.Item(8).Text = UCase(Rsd!NomPere)
If Not IsNull(Rsd!NomMere) Then TxtPers.Item(9).Text = UCase(Rsd!NomMere)
If Not IsNull(Rsd!Ethnie) Then CboEthnie.Text = UCase(Rsd!Ethnie)
'If Not IsNull(Rsd!Taille) Then Taille.Text = UCase(Rsd!Taille)
If Not IsNull(Rsd!DateEntree) Then EntreeService.Text = UCase(Rsd!DateEntree)
If Not IsNull(Rsd!DatePromo) Then DatePromo.Text = (Rsd!DatePromo)
If Not IsNull(Rsd!GrpeSanguin) Then CboRhesus.Text = UCase(Rsd!GrpeSanguin)
If Not IsNull(Rsd!NomReligion) Then CboReligion.Text = UCase(Rsd!NomReligion)
If Not IsNull(Rsd!Situation) Then CboPosition.Text = UCase(Rsd!Situation)
If Not IsNull(Rsd!NomSection) Then CboSection.Text = UCase(Rsd!NomSection)
If Not IsNull(Rsd!NiveauScolaire) Then CboNiveau.Text = UCase(Rsd!NiveauScolaire)
If Not IsNull(Rsd!Specialite) Then CboSpecialite.Text = UCase(Rsd!Specialite)
If Not IsNull(Rsd!Diplome) Then CboDiplome.Text = UCase(Rsd!Diplome)
If Not IsNull(Rsd!Fonction) Then CboFonction.Text = UCase(Rsd!Fonction)
If Not IsNull(Rsd!Famille) Then CboFamille.Text = UCase(Rsd!Famille)
If Not IsNull(Rsd!Categorie) Then CboCategorie.Text = UCase(Rsd!Categorie)
If Not IsNull(Rsd!CorpsOrigine) Then CboCorps.Text = UCase(Rsd!CorpsOrigine)
If Not IsNull(Rsd!DateEng) Then DateEng.Text = (Rsd!DateEng)
'If Not IsNull(Rsd!NbEnft) Then NbEnfts.Text = UCase(Rsd!NbEnft)
If Not IsNull(Rsd!Surnom) Then TxtPers.Item(26).Text = UCase(Rsd!Surnom)
'If Not IsNull(Rsd!Photo) Then TxtPhoto.Caption = Rsd!Photo

If Not IsNull(Rsd.Fields("Photo1").Value) Then Stm.Write Rsd.Fields("Photo1").Value

sTemporyFileName = GenerateTemporyFileName("PGM")
Stm.SaveToFile sTemporyFileName, adSaveCreateOverWrite And adSaveCreateNotExist
Set Photo.Picture = LoadPicture(sTemporyFileName)
Kill sTemporyFileName

'If Rsd!Photo = "" Then
'TxtPhoto.Caption = ""
'End If

'If TxtPhoto.Caption = "" Then
'Photo.Picture = Nothing

'Else
'Photo.Picture = LoadPicture(TxtPhoto.Caption)
'End If
Rsd.Close
Stm.Close

Set Rsd = Nothing
Set Stm = Nothing

End Sub

J'ai une Erreur [ Run-time error "3219" Operation is not allowed in this Context. ]
Aidez moi s'il vous plait. Je souhaiterais apprendre. Merci à tous de me repondre, même par mail. E-mail: laurent_guehi@yahoo.fr
Afficher la suite 

2 réponses

Meilleure réponse
Messages postés
13368
Date d'inscription
lundi 13 décembre 2004
Statut
Modérateur
Dernière intervention
3 février 2018
23
3
Merci
salut,

pas besoin de passer par un fichier temporaire
http://faq.vb.free.fr/index.php?question=127

++
[hr]

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 124 internautes nous ont dit merci ce mois-ci

Commenter la réponse de PCPT
Messages postés
99
Date d'inscription
jeudi 17 janvier 2008
Statut
Membre
Dernière intervention
25 juillet 2013
1
0
Merci
Merci pour votre reponse, je vais su r le site de ce pas pour vérifier. Merci encore
Commenter la réponse de cs_warzet