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" a écrit dans le message de
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" a écrit dans le message de
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
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" <michdenis@hotmail.com> a écrit dans le message de
news:usstcoZHEHA.3992@TK2MSFTNGP10.phx.gbl...
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" <mikar@prodigy.net.mx> a écrit dans le message de
news:uJTXvnXHEHA.3584@TK2MSFTNGP09.phx.gbl...
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
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" a écrit dans le message de
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" a écrit dans le message de
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
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!
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!
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!
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!
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!
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!
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" a écrit dans le 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" wrote in message
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!
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" <mikarxxx@prodigy.net.mx> a écrit dans le message
de
news:uTZf2eKIEHA.520@tk2msftngp13.phx.gbl...
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
mikar@prodigy.net.mx
"michdenis" <michdenis@hotmail.com> wrote in message
news:O73HQVaHEHA.2876@TK2MSFTNGP09.phx.gbl...
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!
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" a écrit dans le 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" wrote in message
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!
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" a écrit dans le 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" wrote in message
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!
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" <mikarxxx@prodigy.net.mx> a écrit dans le message
de
news:uTZf2eKIEHA.520@tk2msftngp13.phx.gbl...
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
mikar@prodigy.net.mx
"michdenis" <michdenis@hotmail.com> wrote in message
news:O73HQVaHEHA.2876@TK2MSFTNGP09.phx.gbl...
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!
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" a écrit dans le 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" wrote in message
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!
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" a écrit dans le message
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" wrote in message
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" a écrit dans le
message
denews:
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
photoreste á gauche.
Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu
votreprocé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" wrote in message
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!
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" <mikarxxx@prodigy.net.mx> a écrit dans le message
de
news:OppF9H%23IEHA.2824@TK2MSFTNGP12.phx.gbl...
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" <michdenis@hotmail.com> wrote in message
news:%23gpo7oKIEHA.1528@TK2MSFTNGP09.phx.gbl...
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" <mikarxxx@prodigy.net.mx> a écrit dans le
message
de
news:uTZf2eKIEHA.520@tk2msftngp13.phx.gbl...
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
mikar@prodigy.net.mx
"michdenis" <michdenis@hotmail.com> wrote in message
news:O73HQVaHEHA.2876@TK2MSFTNGP09.phx.gbl...
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!
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" a écrit dans le message
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" wrote in message
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" a écrit dans le
message
denews:
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
photoreste á gauche.
Au sujet de la base de données de jeudi dernier, j'ai pourtant bien lu
votreprocé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" wrote in message
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!