Re: automatiser l insertion de photo

Le
Michele Severac Dumont
Bonjour á tous
J'ai essayé les 2 procedures de Michdenis, ca marche tres bien, toutes mes
felicitations.
Pour éviter que la photo soit distorsionneé j'ai mis une valeur 180 et 140 á
Image.Width et Image.Height pour réduire la taille de la photo. Je ne sais
pas si c'est correct mais le résultat est satisfaisant. Par contre
j'aimerais faire un petit changement, est-il possible que la photo soit
centreé et en bas de la cellule ? J'ai tout de meme cherché dans l'aide
avant de demander, malheureusement je n'ai pas vos connaissances ce qui fait
que je patine.

FxM je n'oublierai pas de tester votre procédure je suis sure qu'elle marche
tres bien

Un grand merci á michdenis et FxM

Michele
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
michdenis
Le #1282577
Bonjour Michèle,

(Il ne faut pas oublié qu'il est toujours plus simple d'utiliser le même fil de discussion... c'est plus facile à suivre
pour tout le monde)

Si j'ai bien compris, tu veux centrer ton image horizontalement dans la cellule retenue ?

Pour centrer quelque chose dans le sens horizontal d'une cellule, ce n'est pas une mince tâche car la largeur d'une
cellule a une mesure un peu spécial.. tu peux regarder dans l'aide ....

Ma suggestion, cela peut être possible si tu utilise la propriété "Left" de l'objet "Range". La raison est simple, la
propriété retourne la distance qui existe entre extrême gauche de la cellule et le bord gauche de l'application.

à titre d'exemple, tu veux obtenir la coordonnée horizontale du milieu de la celle C5

la formule serait à titre d'exemple

MilieurCelluleC5 = (Range("D5").left - Range("D5").left) / 2


Voici la procédure modifiée mais elle n'est pas testée...!
'-------------------
Sub Insérer(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
MilieurCellule = (rg.left - rg.offset(,1).left) / 2
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------


Salutations!





"Michele Severac Dumont" Bonjour á tous
J'ai essayé les 2 procedures de Michdenis, ca marche tres bien, toutes mes
felicitations.
Pour éviter que la photo soit distorsionneé j'ai mis une valeur 180 et 140 á
Image.Width et Image.Height pour réduire la taille de la photo. Je ne sais
pas si c'est correct mais le résultat est satisfaisant. Par contre
j'aimerais faire un petit changement, est-il possible que la photo soit
centreé et en bas de la cellule ? J'ai tout de meme cherché dans l'aide
avant de demander, malheureusement je n'ai pas vos connaissances ce qui fait
que je patine.

FxM je n'oublierai pas de tester votre procédure je suis sure qu'elle marche
tres bien

Un grand merci á michdenis et FxM

Michele
michdenis
Le #1282562
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!



"michdenis" Bonjour Michèle,

(Il ne faut pas oublié qu'il est toujours plus simple d'utiliser le même fil de discussion... c'est plus facile à suivre
pour tout le monde)

Si j'ai bien compris, tu veux centrer ton image horizontalement dans la cellule retenue ?

Pour centrer quelque chose dans le sens horizontal d'une cellule, ce n'est pas une mince tâche car la largeur d'une
cellule a une mesure un peu spécial.. tu peux regarder dans l'aide ....

Ma suggestion, cela peut être possible si tu utilise la propriété "Left" de l'objet "Range". La raison est simple, la
propriété retourne la distance qui existe entre extrême gauche de la cellule et le bord gauche de l'application.

à titre d'exemple, tu veux obtenir la coordonnée horizontale du milieu de la celle C5

la formule serait à titre d'exemple

MilieurCelluleC5 = (Range("D5").left - Range("D5").left) / 2


Voici la procédure modifiée mais elle n'est pas testée...!
'-------------------
Sub Insérer(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------


Salutations!





"Michele Severac Dumont" Bonjour á tous
J'ai essayé les 2 procedures de Michdenis, ca marche tres bien, toutes mes
felicitations.
Pour éviter que la photo soit distorsionneé j'ai mis une valeur 180 et 140 á
Image.Width et Image.Height pour réduire la taille de la photo. Je ne sais
pas si c'est correct mais le résultat est satisfaisant. Par contre
j'aimerais faire un petit changement, est-il possible que la photo soit
centreé et en bas de la cellule ? J'ai tout de meme cherché dans l'aide
avant de demander, malheureusement je n'ai pas vos connaissances ce qui fait
que je patine.

FxM je n'oublierai pas de tester votre procédure je suis sure qu'elle marche
tres bien

Un grand merci á michdenis et FxM

Michele
Michele Severac Dumont
Le #1282533
Pardon
Je ne le ferai plus, c est promis
Je vais tester cette procédure. Je suis sure qu'elle sera parfaite.
D'apres certains conseils il est recommendable de poser une question á la
fois donc si ce n'est pas trop demander, j'en ai une autre.
Dans un autre repertoire (c:employees) j'ai une bases de données
"employee.dbf" (foxpro v.2.5 Msdos) dans laquelle le numero de l'employé est
le meme que celui de la photo. Puisque la photo (c:photos) s'insere en
relation au numero capturé dans la cellule comment faire pour soutirer
directement de la base de données "employee.dbf" le nom de employé (champ:
prenoms,nom ) et date d'entrée dans l'entreprise(champ: entrée) , ce qui
fait que les champs prenoms+nom iraient dans la cellule C2,F2, I2,
C9,F9,I9..... et la date d'entrée dans la cellule C4,F4,I4,
C11,F11,I11...etc...

C'est la premiere fois que je me lance avec VB, je suppose qu'il doit y
avoir un moyen. Malheureusement je débute dans ce domaine et comme fait
expres, tout est urgent

Merci bien michdenis
Michele

"michdenis" news:
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!



"michdenis" news:

Bonjour Michèle,

(Il ne faut pas oublié qu'il est toujours plus simple d'utiliser le même
fil de discussion... c'est plus facile à suivre

pour tout le monde)

Si j'ai bien compris, tu veux centrer ton image horizontalement dans la
cellule retenue ?


Pour centrer quelque chose dans le sens horizontal d'une cellule, ce n'est
pas une mince tâche car la largeur d'une

cellule a une mesure un peu spécial.. tu peux regarder dans l'aide ....

Ma suggestion, cela peut être possible si tu utilise la propriété "Left"
de l'objet "Range". La raison est simple, la

propriété retourne la distance qui existe entre extrême gauche de la
cellule et le bord gauche de l'application.


à titre d'exemple, tu veux obtenir la coordonnée horizontale du milieu de
la celle C5


la formule serait à titre d'exemple

MilieurCelluleC5 = (Range("D5").left - Range("D5").left) / 2


Voici la procédure modifiée mais elle n'est pas testée...!
'-------------------
Sub Insérer(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------


Salutations!





"Michele Severac Dumont" news:

Bonjour á tous
J'ai essayé les 2 procedures de Michdenis, ca marche tres bien, toutes mes
felicitations.
Pour éviter que la photo soit distorsionneé j'ai mis une valeur 180 et 140
á

Image.Width et Image.Height pour réduire la taille de la photo. Je ne sais
pas si c'est correct mais le résultat est satisfaisant. Par contre
j'aimerais faire un petit changement, est-il possible que la photo soit
centreé et en bas de la cellule ? J'ai tout de meme cherché dans l'aide
avant de demander, malheureusement je n'ai pas vos connaissances ce qui
fait

que je patine.

FxM je n'oublierai pas de tester votre procédure je suis sure qu'elle
marche

tres bien

Un grand merci á michdenis et FxM

Michele







michdenis
Le #1282528
Bonjour Michèle,


Dans la feuille module où l'action doit se dérouler, copie ceci :

Tu dois ajouter la bibliothèque suivante à ton projet Excel :

Dans la fenêtre VBE(visual basic editor)
Barre des menus / outils / référence / coche ceci :


"Microsoft activex data objects 2.0 librairy"

Comme je n'ai jamais travaillé avec FoxPro, je ne suis pas certain
que c'est la bibliothèque la mieux adapté ....!

Voici les macros intégrés : à toi maintenant de t'amuser pour mettre tout ce qui suit au point !!!

'-----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rg As Range, Rg1 As Range, Img As String, Rep As String
Set Rg = Range("A3,F3,I3,C10,F10,I10,C17,F17,I17,C24,F24,I24")

Rep = "C:Photos" ' à définir répertoire des photos

On Error Resume Next
Set Rg1 = Intersect(Target, Rg)
If Not Rg1 Is Nothing Then
For Each C In Rg1
Shapes(C.Offset(2).Address(0, 0)).Delete
Img = Rep & C.Value
If Dir(Img) <> "" Then
'Insère Image de l'employé
InsérerImage Rg1.Parent.Name, C.Offset(2), Img
'Insère information sur l'employé
InformationsSurEmployés C
End If
Next
End If

End Sub
'-----------------------------------

Sub Insérer(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------

Sub InformationsSurEmployés(ByVal Rg As Range)

Dim Cnt As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Requete As String, CheminDb As String

'Définir le chemin de ta base de données
CheminDb = "C:excelcomptoir.mdb"

'Définr ta requête en SQL pour extraire les données.
'[N° employé], Nom, Prénom [date de naissance] sont
'les champs de la base de données, à toi de corriger
'le nom des champs selon ton application. Tu utilises
'les crochets droits si le nom du champ contient un
'espace

Requete = "Select [N° employé], Nom, Prénom, " & vbCrLf & _
"[date de naissance] From Employés "

Application.EnableEvents = False

'Je ne suis pas certain de la chaîne de connection soit Ok, je n'ai jamais
'travaillé avec FoxPro...
Cnt.Open "Driver={Microsoft Visual FoxPro Driver};" & _
"SourceTypeÛF;" & _
"SourceDB=" & CheminDb & ";" & _
"Exclusive=No;"

'Ouverture du recordset
Rst.Open Requete, Cnt, adOpenStatic

'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
MsgBox "Aucun enregistrement trouvé." & vbCrLf & _
"Fin de l'opération.", vbInformation + vbOKOnly, _
"Annulation"
' Ferme la connection et le recordset
Rst.Close: Cnt.Close
'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True
Exit Sub
End If

'Identifie l'enregistrement qui correspond au numéro
'de l'employé
Rst.Find "[N° employé]=" & Rg

'Test pour savoir si un enregistrement a été trouvé.
If Rst.EOF Then
MsgBox "Enregistrement pas trouvé."
Else
'Si trouvé, copie sur la même ligne où se
'trouve la cellule contenant le numéro d'employé
'l'information de l'enregistrement trouvé dans
'la base de données. à toi de choisir
'où tu veux copier ces infos. Pour ce faire, modifie
'les chiffres 1 de la méthode Offset.
Cells(Rg.Row, 3).Offset(1,1) = Rst(1) 'Nom Colonne C
Cells(Rg.Row, 4).Offset(1,1) = Rst(2) 'Prénom Colonne D
Cells(Rg.Row, 5).Offset(1,1) = Rst(2) 'date Colonne E
End If

'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True

End Sub
'----------------------------------------


Salutations!
Michele Severac Dumont
Le #1240211
Bonjour
Michdenis j'ai modifié la procedure et testé. L'image se positionne au
milieu des 2 colonnes anterieures, p.e. A4 et B4 au lieu de C4, D4,E4 au
lieu de F4..... il est vrai que la tache n'est pas facile, je vous en
remercie et pour eviter un casse-tete, je crois qu'il est mieux que la photo
reste á gauche.

Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu votre
procédure et aujourd'hui lundi je suis surprise de ne plus la voir ni mon
message en rapport á celle-ci (pourquoi?). Vous serait-il possible de
remettre votre procédure dans ce groupe ?

Merci bien Michdenis

Michele






"michdenis" news:
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!



michdenis
Le #1239977
Bonjour Michèle,


Dans la feuille module où l'action doit se dérouler, copie ceci :

Tu dois ajouter la bibliothèque suivante à ton projet Excel :

Dans la fenêtre VBE(visual basic editor)
Barre des menus / outils / référence / coche ceci :


"Microsoft activex data objects 2.0 librairy"

Comme je n'ai jamais travaillé avec FoxPro, je ne suis pas certain
que c'est la bibliothèque la mieux adapté ....!

Voici les macros intégrés : à toi maintenant de t'amuser pour mettre tout ce qui suit au point !!!

'-----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rg As Range, Rg1 As Range, Img As String, Rep As String
Set Rg = Range("A3,F3,I3,C10,F10,I10,C17,F17,I17,C24,F24,I24")

Rep = "C:Photos" ' à définir répertoire des photos

On Error Resume Next
Set Rg1 = Intersect(Target, Rg)
If Not Rg1 Is Nothing Then
For Each C In Rg1
Shapes(C.Offset(2).Address(0, 0)).Delete
Img = Rep & C.Value & ".jpg"
If Dir(Img) <> "" Then
'Insère Image de l'employé
InsérerImage Rg1.Parent.Name, C.Offset(2), Img
'Insère information sur l'employé
InformationsSurEmployés C
End If
Next
End If

End Sub
'-----------------------------------

Sub InsérerImage(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------

Sub InformationsSurEmployés(ByVal Rg As Range)

Dim Cnt As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Requete As String, CheminDb As String

'Définir le chemin de ta base de données
CheminDb = "C:excelcomptoir.mdb"

'Définr ta requête en SQL pour extraire les données.
'[N° employé], Nom, Prénom [date de naissance] sont
'les champs de la base de données, à toi de corriger
'le nom des champs selon ton application. Tu utilises
'les crochets droits si le nom du champ contient un
'espace

Requete = "Select [N° employé], Nom, Prénom, " & vbCrLf & _
"[date de naissance] From Employés "

Application.EnableEvents = False

'Je ne suis pas certain de la chaîne de connection soit Ok, je n'ai jamais
'travaillé avec FoxPro...
Cnt.Open "Driver={Microsoft Visual FoxPro Driver};" & _
"SourceTypeÛF;" & _
"SourceDB=" & CheminDb & ";" & _
"Exclusive=No;"

'Ouverture du recordset
Rst.Open Requete, Cnt, adOpenStatic

'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
MsgBox "Aucun enregistrement trouvé." & vbCrLf & _
"Fin de l'opération.", vbInformation + vbOKOnly, _
"Annulation"
' Ferme la connection et le recordset
Rst.Close: Cnt.Close
'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True
Exit Sub
End If

'Identifie l'enregistrement qui correspond au numéro
'de l'employé
Rst.Find "[N° employé]=" & Rg

'Test pour savoir si un enregistrement a été trouvé.
If Rst.EOF Then
MsgBox "Enregistrement pas trouvé."
Else
'Si trouvé, copie sur la même ligne où se
'trouve la cellule contenant le numéro d'employé
'l'information de l'enregistrement trouvé dans
'la base de données. à toi de choisir
'où tu veux copier ces infos. Pour ce faire, modifie
'les chiffres 1 de la méthode Offset.
Cells(Rg.Row, 3).Offset(1,1) = Rst(1) 'Nom Colonne C
Cells(Rg.Row, 4).Offset(1,1) = Rst(2) 'Prénom Colonne D
Cells(Rg.Row, 5).Offset(1,1) = Rst(2) 'date Colonne E
End If

'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True

End Sub
'----------------------------------------


Salutations!





"Michele Severac Dumont" news:
Bonjour
Michdenis j'ai modifié la procedure et testé. L'image se positionne au
milieu des 2 colonnes anterieures, p.e. A4 et B4 au lieu de C4, D4,E4 au
lieu de F4..... il est vrai que la tache n'est pas facile, je vous en
remercie et pour eviter un casse-tete, je crois qu'il est mieux que la photo
reste á gauche.

Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu votre
procédure et aujourd'hui lundi je suis surprise de ne plus la voir ni mon
message en rapport á celle-ci (pourquoi?). Vous serait-il possible de
remettre votre procédure dans ce groupe ?

Merci bien Michdenis

Michele






"michdenis" news:
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!



Michele Severac Dumont
Le #1272190
Bonjour
Je m'excuse Michdenis,je ne suis en retard pour vous remiercier, j'ai eu des
problemes de ligne telephonique.
J'ai fait les changements ca ne marche pas. Je travaille sous la plateforme
DOS, je suppose que le driver n'est pas le meme
que "Microsoft Visual FoxPro Driver". Je crois qu'il faut que j'installe une
"distribution kit et connectivity" ce qui fait que je suis en train de voir
ca de pres.

Vous faites mention 'Définir le chemin de la base de données" dont
l'extension du fichier est .mdb. C'est quoi mdb, quel est le programme qui
le génere. Dans l'aide de foxpro sous DOS je n'ai rien vu sur ce format.

Quant á la bibliothèque je pense que c'est correct. J'essaie de mettre tout
ca au point et je vous tiendrai au courant

Merci bien
Michele



"michdenis" news:%
Bonjour Michèle,


Dans la feuille module où l'action doit se dérouler, copie ceci :

Tu dois ajouter la bibliothèque suivante à ton projet Excel :

Dans la fenêtre VBE(visual basic editor)
Barre des menus / outils / référence / coche ceci :


"Microsoft activex data objects 2.0 librairy"

Comme je n'ai jamais travaillé avec FoxPro, je ne suis pas certain
que c'est la bibliothèque la mieux adapté ....!

Voici les macros intégrés : à toi maintenant de t'amuser pour mettre tout
ce qui suit au point !!!


'-----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rg As Range, Rg1 As Range, Img As String, Rep As String
Set Rg = Range("A3,F3,I3,C10,F10,I10,C17,F17,I17,C24,F24,I24")

Rep = "C:Photos" ' à définir répertoire des photos

On Error Resume Next
Set Rg1 = Intersect(Target, Rg)
If Not Rg1 Is Nothing Then
For Each C In Rg1
Shapes(C.Offset(2).Address(0, 0)).Delete
Img = Rep & C.Value & ".jpg"
If Dir(Img) <> "" Then
'Insère Image de l'employé
InsérerImage Rg1.Parent.Name, C.Offset(2), Img
'Insère information sur l'employé
InformationsSurEmployés C
End If
Next
End If

End Sub
'-----------------------------------

Sub InsérerImage(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------

Sub InformationsSurEmployés(ByVal Rg As Range)

Dim Cnt As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Requete As String, CheminDb As String

'Définir le chemin de ta base de données
CheminDb = "C:excelcomptoir.mdb"

'Définr ta requête en SQL pour extraire les données.
'[N° employé], Nom, Prénom [date de naissance] sont
'les champs de la base de données, à toi de corriger
'le nom des champs selon ton application. Tu utilises
'les crochets droits si le nom du champ contient un
'espace

Requete = "Select [N° employé], Nom, Prénom, " & vbCrLf & _
"[date de naissance] From Employés "

Application.EnableEvents = False

'Je ne suis pas certain de la chaîne de connection soit Ok, je n'ai jamais
'travaillé avec FoxPro...
Cnt.Open "Driver={Microsoft Visual FoxPro Driver};" & _
"SourceTypeÛF;" & _
"SourceDB=" & CheminDb & ";" & _
"Exclusive=No;"

'Ouverture du recordset
Rst.Open Requete, Cnt, adOpenStatic

'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
MsgBox "Aucun enregistrement trouvé." & vbCrLf & _
"Fin de l'opération.", vbInformation + vbOKOnly, _
"Annulation"
' Ferme la connection et le recordset
Rst.Close: Cnt.Close
'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True
Exit Sub
End If

'Identifie l'enregistrement qui correspond au numéro
'de l'employé
Rst.Find "[N° employé]=" & Rg

'Test pour savoir si un enregistrement a été trouvé.
If Rst.EOF Then
MsgBox "Enregistrement pas trouvé."
Else
'Si trouvé, copie sur la même ligne où se
'trouve la cellule contenant le numéro d'employé
'l'information de l'enregistrement trouvé dans
'la base de données. à toi de choisir
'où tu veux copier ces infos. Pour ce faire, modifie
'les chiffres 1 de la méthode Offset.
Cells(Rg.Row, 3).Offset(1,1) = Rst(1) 'Nom Colonne C
Cells(Rg.Row, 4).Offset(1,1) = Rst(2) 'Prénom Colonne D
Cells(Rg.Row, 5).Offset(1,1) = Rst(2) 'date Colonne E
End If

'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True

End Sub
'----------------------------------------


Salutations!





"Michele Severac Dumont" de

news:
Bonjour
Michdenis j'ai modifié la procedure et testé. L'image se positionne au
milieu des 2 colonnes anterieures, p.e. A4 et B4 au lieu de C4, D4,E4 au
lieu de F4..... il est vrai que la tache n'est pas facile, je vous en
remercie et pour eviter un casse-tete, je crois qu'il est mieux que la
photo

reste á gauche.

Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu
votre

procédure et aujourd'hui lundi je suis surprise de ne plus la voir ni mon
message en rapport á celle-ci (pourquoi?). Vous serait-il possible de
remettre votre procédure dans ce groupe ?

Merci bien Michdenis

Michele






"michdenis" news:
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!








michdenis
Le #1251539
Bonjour Michele,

Les procédures soumises ont été testées avec une base de données "Access" . L'extension pour ce type de fichier est
.mdb.
Ces procédures fonctionnaient très bien. Je crois avoir mentionné que tu dois adapter ces procédures à un environnement
pour FoxPro ... et là je ne peux pas t'aider ... je ne connais pas explicitement cela et je ne puis tester les
procédures.


Salutations!




"Michele Severac Dumont" news:OppF9H%
Bonjour
Je m'excuse Michdenis,je ne suis en retard pour vous remiercier, j'ai eu des
problemes de ligne telephonique.
J'ai fait les changements ca ne marche pas. Je travaille sous la plateforme
DOS, je suppose que le driver n'est pas le meme
que "Microsoft Visual FoxPro Driver". Je crois qu'il faut que j'installe une
"distribution kit et connectivity" ce qui fait que je suis en train de voir
ca de pres.

Vous faites mention 'Définir le chemin de la base de données" dont
l'extension du fichier est .mdb. C'est quoi mdb, quel est le programme qui
le génere. Dans l'aide de foxpro sous DOS je n'ai rien vu sur ce format.

Quant á la bibliothèque je pense que c'est correct. J'essaie de mettre tout
ca au point et je vous tiendrai au courant

Merci bien
Michele



"michdenis" news:%
Bonjour Michèle,


Dans la feuille module où l'action doit se dérouler, copie ceci :

Tu dois ajouter la bibliothèque suivante à ton projet Excel :

Dans la fenêtre VBE(visual basic editor)
Barre des menus / outils / référence / coche ceci :


"Microsoft activex data objects 2.0 librairy"

Comme je n'ai jamais travaillé avec FoxPro, je ne suis pas certain
que c'est la bibliothèque la mieux adapté ....!

Voici les macros intégrés : à toi maintenant de t'amuser pour mettre tout
ce qui suit au point !!!


'-----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rg As Range, Rg1 As Range, Img As String, Rep As String
Set Rg = Range("A3,F3,I3,C10,F10,I10,C17,F17,I17,C24,F24,I24")

Rep = "C:Photos" ' à définir répertoire des photos

On Error Resume Next
Set Rg1 = Intersect(Target, Rg)
If Not Rg1 Is Nothing Then
For Each C In Rg1
Shapes(C.Offset(2).Address(0, 0)).Delete
Img = Rep & C.Value & ".jpg"
If Dir(Img) <> "" Then
'Insère Image de l'employé
InsérerImage Rg1.Parent.Name, C.Offset(2), Img
'Insère information sur l'employé
InformationsSurEmployés C
End If
Next
End If

End Sub
'-----------------------------------

Sub InsérerImage(Feuille As String, RgImage As Range, NomImage As String)
Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)
End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------

Sub InformationsSurEmployés(ByVal Rg As Range)

Dim Cnt As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Requete As String, CheminDb As String

'Définir le chemin de ta base de données
CheminDb = "C:excelcomptoir.mdb"

'Définr ta requête en SQL pour extraire les données.
'[N° employé], Nom, Prénom [date de naissance] sont
'les champs de la base de données, à toi de corriger
'le nom des champs selon ton application. Tu utilises
'les crochets droits si le nom du champ contient un
'espace

Requete = "Select [N° employé], Nom, Prénom, " & vbCrLf & _
"[date de naissance] From Employés "

Application.EnableEvents = False

'Je ne suis pas certain de la chaîne de connection soit Ok, je n'ai jamais
'travaillé avec FoxPro...
Cnt.Open "Driver={Microsoft Visual FoxPro Driver};" & _
"SourceTypeÛF;" & _
"SourceDB=" & CheminDb & ";" & _
"Exclusive=No;"

'Ouverture du recordset
Rst.Open Requete, Cnt, adOpenStatic

'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
MsgBox "Aucun enregistrement trouvé." & vbCrLf & _
"Fin de l'opération.", vbInformation + vbOKOnly, _
"Annulation"
' Ferme la connection et le recordset
Rst.Close: Cnt.Close
'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True
Exit Sub
End If

'Identifie l'enregistrement qui correspond au numéro
'de l'employé
Rst.Find "[N° employé]=" & Rg

'Test pour savoir si un enregistrement a été trouvé.
If Rst.EOF Then
MsgBox "Enregistrement pas trouvé."
Else
'Si trouvé, copie sur la même ligne où se
'trouve la cellule contenant le numéro d'employé
'l'information de l'enregistrement trouvé dans
'la base de données. à toi de choisir
'où tu veux copier ces infos. Pour ce faire, modifie
'les chiffres 1 de la méthode Offset.
Cells(Rg.Row, 3).Offset(1,1) = Rst(1) 'Nom Colonne C
Cells(Rg.Row, 4).Offset(1,1) = Rst(2) 'Prénom Colonne D
Cells(Rg.Row, 5).Offset(1,1) = Rst(2) 'date Colonne E
End If

'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True

End Sub
'----------------------------------------


Salutations!





"Michele Severac Dumont" de

news:
Bonjour
Michdenis j'ai modifié la procedure et testé. L'image se positionne au
milieu des 2 colonnes anterieures, p.e. A4 et B4 au lieu de C4, D4,E4 au
lieu de F4..... il est vrai que la tache n'est pas facile, je vous en
remercie et pour eviter un casse-tete, je crois qu'il est mieux que la
photo

reste á gauche.

Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu
votre

procédure et aujourd'hui lundi je suis surprise de ne plus la voir ni mon
message en rapport á celle-ci (pourquoi?). Vous serait-il possible de
remettre votre procédure dans ce groupe ?

Merci bien Michdenis

Michele






"michdenis" news:
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!








Michele Severac Dumont
Le #1257437
Bonjour Michdenis
Je vais importer depuis Access ma base de données(foxpro) afin de pouvoir
tester et voir le résultat

Merci
Michele


"michdenis" news:
Bonjour Michele,

Les procédures soumises ont été testées avec une base de données "Access"
. L'extension pour ce type de fichier est

.mdb.
Ces procédures fonctionnaient très bien. Je crois avoir mentionné que tu
dois adapter ces procédures à un environnement

pour FoxPro ... et là je ne peux pas t'aider ... je ne connais pas
explicitement cela et je ne puis tester les

procédures.


Salutations!




"Michele Severac Dumont" de

news:OppF9H%
Bonjour
Je m'excuse Michdenis,je ne suis en retard pour vous remiercier, j'ai eu
des

problemes de ligne telephonique.
J'ai fait les changements ca ne marche pas. Je travaille sous la
plateforme

DOS, je suppose que le driver n'est pas le meme
que "Microsoft Visual FoxPro Driver". Je crois qu'il faut que j'installe
une

"distribution kit et connectivity" ce qui fait que je suis en train de
voir

ca de pres.

Vous faites mention 'Définir le chemin de la base de données" dont
l'extension du fichier est .mdb. C'est quoi mdb, quel est le programme qui
le génere. Dans l'aide de foxpro sous DOS je n'ai rien vu sur ce format.

Quant á la bibliothèque je pense que c'est correct. J'essaie de mettre
tout

ca au point et je vous tiendrai au courant

Merci bien
Michele



"michdenis" news:%
Bonjour Michèle,


Dans la feuille module où l'action doit se dérouler, copie ceci :

Tu dois ajouter la bibliothèque suivante à ton projet Excel :

Dans la fenêtre VBE(visual basic editor)
Barre des menus / outils / référence / coche ceci :


"Microsoft activex data objects 2.0 librairy"

Comme je n'ai jamais travaillé avec FoxPro, je ne suis pas certain
que c'est la bibliothèque la mieux adapté ....!

Voici les macros intégrés : à toi maintenant de t'amuser pour mettre
tout


ce qui suit au point !!!

'-----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

Dim Rg As Range, Rg1 As Range, Img As String, Rep As String
Set Rg = Range("A3,F3,I3,C10,F10,I10,C17,F17,I17,C24,F24,I24")

Rep = "C:Photos" ' à définir répertoire des photos

On Error Resume Next
Set Rg1 = Intersect(Target, Rg)
If Not Rg1 Is Nothing Then
For Each C In Rg1
Shapes(C.Offset(2).Address(0, 0)).Delete
Img = Rep & C.Value & ".jpg"
If Dir(Img) <> "" Then
'Insère Image de l'employé
InsérerImage Rg1.Parent.Name, C.Offset(2), Img
'Insère information sur l'employé
InformationsSurEmployés C
End If
Next
End If

End Sub
'-----------------------------------

Sub InsérerImage(Feuille As String, RgImage As Range, NomImage As
String)


Dim MilieurCellule As Double
Dim Rg As Range
Set Rg = Worksheets(Feuille).Range(RgImage.Address)
With Rg
Largeur = .Offset(, 1)(, .Columns.Count).Left - .Left
Hauteur = .Offset(.Rows.Count).Top - .Item(1).Top
Set Image = Worksheets(Feuille).Pictures.Insert(NomImage)
MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) /
2)


End With
With Image
.Left = MilieurCellule
.Top = Rg.Top
.Name = Rg.Address(0, 0)
'Largeur de l'image
Image.Width = Largeur
'Hauteur de l'image
Image.Height = Hauteur
'Est-ce que l'image doit se déplacer avec les cellules
'voici les 3 constantes possibles
.Placement = xlFreeFloating 'or xlmove or xlMoveAndSize
'Verrouillé ou pas
.Locked = True 'or False
End With
Set Rg = Nothing
End Sub
'-------------------

Sub InformationsSurEmployés(ByVal Rg As Range)

Dim Cnt As New ADODB.Connection
Dim Rst As New ADODB.Recordset
Dim Requete As String, CheminDb As String

'Définir le chemin de ta base de données
CheminDb = "C:excelcomptoir.mdb"

'Définr ta requête en SQL pour extraire les données.
'[N° employé], Nom, Prénom [date de naissance] sont
'les champs de la base de données, à toi de corriger
'le nom des champs selon ton application. Tu utilises
'les crochets droits si le nom du champ contient un
'espace

Requete = "Select [N° employé], Nom, Prénom, " & vbCrLf & _
"[date de naissance] From Employés "

Application.EnableEvents = False

'Je ne suis pas certain de la chaîne de connection soit Ok, je n'ai
jamais


'travaillé avec FoxPro...
Cnt.Open "Driver={Microsoft Visual FoxPro Driver};" & _
"SourceTypeÛF;" & _
"SourceDB=" & CheminDb & ";" & _
"Exclusive=No;"

'Ouverture du recordset
Rst.Open Requete, Cnt, adOpenStatic

'Si aucun enregistrement est trouvé lors de la requête
If Rst.RecordCount = 0 Then
MsgBox "Aucun enregistrement trouvé." & vbCrLf & _
"Fin de l'opération.", vbInformation + vbOKOnly, _
"Annulation"
' Ferme la connection et le recordset
Rst.Close: Cnt.Close
'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True
Exit Sub
End If

'Identifie l'enregistrement qui correspond au numéro
'de l'employé
Rst.Find "[N° employé]=" & Rg

'Test pour savoir si un enregistrement a été trouvé.
If Rst.EOF Then
MsgBox "Enregistrement pas trouvé."
Else
'Si trouvé, copie sur la même ligne où se
'trouve la cellule contenant le numéro d'employé
'l'information de l'enregistrement trouvé dans
'la base de données. à toi de choisir
'où tu veux copier ces infos. Pour ce faire, modifie
'les chiffres 1 de la méthode Offset.
Cells(Rg.Row, 3).Offset(1,1) = Rst(1) 'Nom Colonne C
Cells(Rg.Row, 4).Offset(1,1) = Rst(2) 'Prénom Colonne D
Cells(Rg.Row, 5).Offset(1,1) = Rst(2) 'date Colonne E
End If

'Libère la mémoire vive occupée par les objets
Set Rst = Nothing: Set Cnt = Nothing
Set Rg = Nothing
Application.EnableEvents = True

End Sub
'----------------------------------------


Salutations!





"Michele Severac Dumont" message


de
news:
Bonjour
Michdenis j'ai modifié la procedure et testé. L'image se positionne au
milieu des 2 colonnes anterieures, p.e. A4 et B4 au lieu de C4, D4,E4 au
lieu de F4..... il est vrai que la tache n'est pas facile, je vous en
remercie et pour eviter un casse-tete, je crois qu'il est mieux que la
photo

reste á gauche.

Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu
votre

procédure et aujourd'hui lundi je suis surprise de ne plus la voir ni
mon


message en rapport á celle-ci (pourquoi?). Vous serait-il possible de
remettre votre procédure dans ce groupe ?

Merci bien Michdenis

Michele






"michdenis" news:
Tu devrais remplacer dans la procédure :

MilieurCellule = (rg.left - rg.offset(,1).left) / 2

Par

MilieurCellule = rg.left + ((rg.left - rg.offset(,1).left) / 2)


Salutations!













Publicité
Poster une réponse
Anonyme