Transferer des images

Bonsoir,
j'ai bien taper les modifs, vérifier deux fois, ce qui a changé c'est que
maintenant, les fichiers images dans le répertoire sont sous le format:
Picture563, Picture564, etc.
le jpg est parti semble correct car il est enlevé dans la macro Créer
desfichiersimages() à la ligne
MakeImgFile Chemin, S, Ext

Comme le nom des images a déjà l'extension .jpg , j'ai modifié légèrement
la macro.
Je publie l'ensemble pour que ce soit plus facile de t'y retrouver.

Cela devrait rouler... c'était le cas pour mon petit test !

'----------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
'----------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

End Sub

'----------------------------
Sub MakeImgFile(Repertoire As String, S As Shape)
Dim Nom As String
Nom = S.Name
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & Nom
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard

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


Salutations!




"René MATHIEU" a écrit dans le message de news:
43935b06$0$6103$
Bonsoir MichDenis,
merci pour ta réponse, voilà

point A: Dans le répertoire c:airbus
j'ai les fichiers: A380.jpg
A380_cockpit.jpg
A380_fuselage.jpg
"" ""
point B : Nom dans la feuille du classeur = le même que dans le
répertoire,
(obtenu par transfert )

point C : Actuellement pour A380.jpg j'obtiens : Picture532.jpg
pour A380_cockpit j'obtiens
Picture533.jpg et ainsi de suite.
point D : Je voudrai obtenir si c'est possible le nom d'origine, soit
A380.jpg pour la première photo,
a380_cockpit.jpg pour la deuxième , etc...

Informations insuffisantes dans ta présentation de ta problématique.

Prend seulement le cas d'une image....
A )
à l'origine quel le nom + extension du fichier Image que tu insères dans
ta colonne

B ) Quel est le NOM COMPLET de l'image que tu viens tout juste d'insérer
dans le classeur ?

C) A la fin, quand tu transformes l'image en fichier quel est le nom du
fichier + extension ?

D ) Quel nom voudrais-tu qu'il ait ?

P.S. Si tu fais référence au fait que la macro transforme "image 1" et
"Picture 1" , c'est normal pour excel, il travaille en VBA,
et là c'est Américain (en anglais) . Excel fait la transformation tout
seul. Quelle gentillesse ? Cependant, ceci se résout
facilement.


Salutations!




"René MATHIEU" a écrit dans le message de news:
43934824$0$31129$
Bonjour,
Merci pour ces nouvelles macros, je l'ai mises , j'obtient un fichier
avec
des images
que l'on peut passer dans un diaporama, d'autant plus que l'on peut
modifier
les dimensions.
Il me reste un problème que j'essaye de résoudre sans résultat en
bricolant
dans la macro
" Creerdesfichiersimages", c'est de remettre les photos avec leur nom
d'origine
plutôt que " Picture "+ numéro d'image Excel + ".jpg". Ce numéro change
d'ailleurs chaque fois.
Dans la feuille, j'ai une colonne NOMS qui reprend les noms de fichier
photos, les cellules ou j'ai inséré les photos ont elles un Name
identique
au nom de fichier.
J'avoue que j'y perd mon latin.
René

à partir d'une procédure publiée ici par Michel Perron,

Tu exécutes la procédure : Sub CréerDesFichiersImages()
Attention, il y a quelques variables à renseigner :
A ) Chemin : lieu de sauvegare

B ) Tu peux modifier la largeur et la hauteur que l'image aura
dans le fichier image...là.
.Width = 250 'à déterminer
.Height = 175 'à déterminer

C) Ext pour l'extension du fichier.



Dans le haut d'un module standard, déclaration des API
'-------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

'-------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S, Ext
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

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

Sub MakeImgFile(Repertoire As String, S As Shape, Ext As String)

'If TypeName(Selection) = "Range" Then
'If Selection.Areas.Count > 1 Then
'MsgBox " Multiple selections !", 48
'Exit Sub
'End If
'End If
'Selection.CopyPicture 1, 2
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & S.Name & Ext
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub
'-------------------------


Salutations!





"René MATHIEU" a écrit dans le message de news:
43921d02$0$3641$
bonsoir MichDenis,

Voila, j'ai implanté les deux macros, cela fonctionne très bien, j'ai ce
que
j'avais demandé.
Mais j'ai fait une grosse erreur en formulant mes demandes (en fait je
n'ai
pas pensé à cela), car comme les photos ont été réduites à la dimension
des
cellules, je récupère dans le nouveau répertoire des fichiers de deux
ou
trois ko, ce qui est trop petit pour le diaporama (et ne peux être
agrandit ).
En fait je dois importer dans de très grandes cellules, puis les
diminuer
pour le traitement (tri sur critères), puis les réagrandir pour la
création
du nouveau répertoire.
De toute faon c'est jouable car c'est pas tout les jours que l'on fait
cela.
Un tout grand merci.
René

"René MATHIEU" a écrit dans le message de
news:
4391eee7$0$10967$
Bonjour,
Grâce à Michdenis qui m'a fournit une macro VBA, j'ai pu transférer 430
photos d'un répertoire du disque c dans une feuille Excel et y
adjoindre
une
série de critères de tri.
Je dois maintenant retransferer après tri ces photos dans un répertoire
sur
le disque dur.
(Ces photos devraient servir à un diaporama pour un club.)
Est-ce faisable et comment?
Un grand merci d'avance.
René

Bonjour René,

Écoute, Je ne travaille pas pour le FBI. J'apprécierais si tu faisais un peu d'effort pour fournir des commentaires qui se tiennent
sans avoir à répéter toujours les mêmes questions. Je ne suis pas dernier ton écran et je connais pas ton environnement de travail.

QUEL ÉTAIT LE NOM DE TON IMAGE DANS TON CLASSEUR QUI EST DEVENU PICTURE536?

Si dans le nom de ton image dans tes feuilles de calcul, leur nom avait une extension .jpg,(d'après une de tes réponses à ma
question) comment expliques-tu que l'extension du fichier ait disparu ?

J'ai re-testé la procédure sous excel 2003 et Windows xp pro, et tout se passe bien !

À moins que tu aies des observations particulières à communiquer, il m'est difficile de corriger une situation dont je n'arrive à
pas à reproduire. Ce que tu observes est pour le moins surprenant ! Peut être que d'autres membres du forum voudront bien tester la
procédure à partir d'une configuration matérielle différente et confirmeront ou infirmeront tes propos.


Salutations!





"René MATHIEU" a écrit dans le message de news: 43936ae2$0$8835$
Bonsoir,
j'ai bien taper les modifs, vérifier deux fois, ce qui a changé c'est que
maintenant, les fichiers images dans le répertoire sont sous le format:
Picture563, Picture564, etc.
le jpg est parti semble correct car il est enlevé dans la macro Créer
desfichiersimages() à la ligne
MakeImgFile Chemin, S, Ext

Comme le nom des images a déjà l'extension .jpg , j'ai modifié légèrement
la macro.
Je publie l'ensemble pour que ce soit plus facile de t'y retrouver.

Cela devrait rouler... c'était le cas pour mon petit test !

'----------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
'----------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

End Sub

'----------------------------
Sub MakeImgFile(Repertoire As String, S As Shape)
Dim Nom As String
Nom = S.Name
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & Nom
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard

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


Salutations!




"René MATHIEU" a écrit dans le message de news:
43935b06$0$6103$
Bonsoir MichDenis,
merci pour ta réponse, voilà

point A: Dans le répertoire c:airbus
j'ai les fichiers: A380.jpg
A380_cockpit.jpg
A380_fuselage.jpg
"" ""
point B : Nom dans la feuille du classeur = le même que dans le
répertoire,
(obtenu par transfert )

point C : Actuellement pour A380.jpg j'obtiens : Picture532.jpg
pour A380_cockpit j'obtiens
Picture533.jpg et ainsi de suite.
point D : Je voudrai obtenir si c'est possible le nom d'origine, soit
A380.jpg pour la première photo,
a380_cockpit.jpg pour la deuxième , etc...

Informations insuffisantes dans ta présentation de ta problématique.

Prend seulement le cas d'une image....
A )
à l'origine quel le nom + extension du fichier Image que tu insères dans
ta colonne

B ) Quel est le NOM COMPLET de l'image que tu viens tout juste d'insérer
dans le classeur ?

C) A la fin, quand tu transformes l'image en fichier quel est le nom du
fichier + extension ?

D ) Quel nom voudrais-tu qu'il ait ?

P.S. Si tu fais référence au fait que la macro transforme "image 1" et
"Picture 1" , c'est normal pour excel, il travaille en VBA,
et là c'est Américain (en anglais) . Excel fait la transformation tout
seul. Quelle gentillesse ? Cependant, ceci se résout
facilement.


Salutations!




"René MATHIEU" a écrit dans le message de news:
43934824$0$31129$
Bonjour,
Merci pour ces nouvelles macros, je l'ai mises , j'obtient un fichier
avec
des images
que l'on peut passer dans un diaporama, d'autant plus que l'on peut
modifier
les dimensions.
Il me reste un problème que j'essaye de résoudre sans résultat en
bricolant
dans la macro
" Creerdesfichiersimages", c'est de remettre les photos avec leur nom
d'origine
plutôt que " Picture "+ numéro d'image Excel + ".jpg". Ce numéro change
d'ailleurs chaque fois.
Dans la feuille, j'ai une colonne NOMS qui reprend les noms de fichier
photos, les cellules ou j'ai inséré les photos ont elles un Name
identique
au nom de fichier.
J'avoue que j'y perd mon latin.
René

à partir d'une procédure publiée ici par Michel Perron,

Tu exécutes la procédure : Sub CréerDesFichiersImages()
Attention, il y a quelques variables à renseigner :
A ) Chemin : lieu de sauvegare

B ) Tu peux modifier la largeur et la hauteur que l'image aura
dans le fichier image...là.
.Width = 250 'à déterminer
.Height = 175 'à déterminer

C) Ext pour l'extension du fichier.



Dans le haut d'un module standard, déclaration des API
'-------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

'-------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S, Ext
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

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

Sub MakeImgFile(Repertoire As String, S As Shape, Ext As String)

'If TypeName(Selection) = "Range" Then
'If Selection.Areas.Count > 1 Then
'MsgBox " Multiple selections !", 48
'Exit Sub
'End If
'End If
'Selection.CopyPicture 1, 2
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & S.Name & Ext
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub
'-------------------------


Salutations!





"René MATHIEU" a écrit dans le message de news:
43921d02$0$3641$
bonsoir MichDenis,

Voila, j'ai implanté les deux macros, cela fonctionne très bien, j'ai ce
que
j'avais demandé.
Mais j'ai fait une grosse erreur en formulant mes demandes (en fait je
n'ai
pas pensé à cela), car comme les photos ont été réduites à la dimension
des
cellules, je récupère dans le nouveau répertoire des fichiers de deux
ou
trois ko, ce qui est trop petit pour le diaporama (et ne peux être
agrandit ).
En fait je dois importer dans de très grandes cellules, puis les
diminuer
pour le traitement (tri sur critères), puis les réagrandir pour la
création
du nouveau répertoire.
De toute faon c'est jouable car c'est pas tout les jours que l'on fait
cela.
Un tout grand merci.
René

"René MATHIEU" a écrit dans le message de
news:
4391eee7$0$10967$
Bonjour,
Grâce à Michdenis qui m'a fournit une macro VBA, j'ai pu transférer 430
photos d'un répertoire du disque c dans une feuille Excel et y
adjoindre
une
série de critères de tri.
Je dois maintenant retransferer après tri ces photos dans un répertoire
sur
le disque dur.
(Ces photos devraient servir à un diaporama pour un club.)
Est-ce faisable et comment?
Un grand merci d'avance.
René

Bonjour Michel,
La communication, n'est probablement pas mon fort alors voilà

1 - Le répertoire d'origine contient des photos dont les noms sont pour les
deux premiers:
A380.jpg
A380cockpit.jpg
et ainsi de suite.

2 - Dans la feuille de calcul, j'ai dans
la cellule A1 le titre de la colonne
la cellule A2 A380.jpg
la cellule A3 A380cockpit.jpg

3 - la cellule A2 s'appelle A380.jpg
la cellule A3 s'appelle A380cockpit.jpg
les noms de cellule servent au transfert des photos

4 - Les photos une fois chargées s'appellent
en A1 image 578
en A2 image 579
le nombre évoluant chaque fois que l'on transfert les images.

5 - Après transfert des photos, le contenu (sous la photo) et le nom de la
cellule reste inchangé.

6 - Dans le répertoire de transfert d'images, les photos deviennent

Picture 578 alors que je voudrai A380.jpg
Picture 579 alors que je voudrai A380cockpit.jpg

Voila, je ne sais pas en dire plus, mon objectif est de retrouver les mêmes
noms de fichier dans les répertoire d'entrée et de sortie.

amicalement

Écoute, Je ne travaille pas pour le FBI. J'apprécierais si tu faisais un
peu d'effort pour fournir des commentaires qui se tiennent
sans avoir à répéter toujours les mêmes questions. Je ne suis pas dernier
ton écran et je connais pas ton environnement de travail.

QUEL ÉTAIT LE NOM DE TON IMAGE DANS TON CLASSEUR QUI EST DEVENU
PICTURE536?

Si dans le nom de ton image dans tes feuilles de calcul, leur nom avait
une extension .jpg,(d'après une de tes réponses à ma
question) comment expliques-tu que l'extension du fichier ait disparu ?

J'ai re-testé la procédure sous excel 2003 et Windows xp pro, et tout se
passe bien !

À moins que tu aies des observations particulières à communiquer, il m'est
difficile de corriger une situation dont je n'arrive à
pas à reproduire. Ce que tu observes est pour le moins surprenant ! Peut
être que d'autres membres du forum voudront bien tester la
procédure à partir d'une configuration matérielle différente et
confirmeront ou infirmeront tes propos.


Salutations!





"René MATHIEU" a écrit dans le message de news:
43936ae2$0$8835$
Bonsoir,
j'ai bien taper les modifs, vérifier deux fois, ce qui a changé c'est que
maintenant, les fichiers images dans le répertoire sont sous le format:
Picture563, Picture564, etc.
le jpg est parti semble correct car il est enlevé dans la macro Créer
desfichiersimages() à la ligne
MakeImgFile Chemin, S, Ext

Comme le nom des images a déjà l'extension .jpg , j'ai modifié légèrement
la macro.
Je publie l'ensemble pour que ce soit plus facile de t'y retrouver.

Cela devrait rouler... c'était le cas pour mon petit test !

'----------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
'----------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

End Sub

'----------------------------
Sub MakeImgFile(Repertoire As String, S As Shape)
Dim Nom As String
Nom = S.Name
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & Nom
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard

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


Salutations!




"René MATHIEU" a écrit dans le message de news:
43935b06$0$6103$
Bonsoir MichDenis,
merci pour ta réponse, voilà

point A: Dans le répertoire c:airbus
j'ai les fichiers: A380.jpg
A380_cockpit.jpg
A380_fuselage.jpg
"" ""
point B : Nom dans la feuille du classeur = le même que dans le
répertoire,
(obtenu par transfert )

point C : Actuellement pour A380.jpg j'obtiens : Picture532.jpg
pour A380_cockpit j'obtiens
Picture533.jpg et ainsi de suite.
point D : Je voudrai obtenir si c'est possible le nom d'origine, soit
A380.jpg pour la première photo,
a380_cockpit.jpg pour la deuxième , etc...

Informations insuffisantes dans ta présentation de ta problématique.

Prend seulement le cas d'une image....
A )
à l'origine quel le nom + extension du fichier Image que tu insères dans
ta colonne

B ) Quel est le NOM COMPLET de l'image que tu viens tout juste d'insérer
dans le classeur ?

C) A la fin, quand tu transformes l'image en fichier quel est le nom du
fichier + extension ?

D ) Quel nom voudrais-tu qu'il ait ?

P.S. Si tu fais référence au fait que la macro transforme "image 1" et
"Picture 1" , c'est normal pour excel, il travaille en VBA,
et là c'est Américain (en anglais) . Excel fait la transformation tout
seul. Quelle gentillesse ? Cependant, ceci se résout
facilement.


Salutations!




"René MATHIEU" a écrit dans le message de news:
43934824$0$31129$
Bonjour,
Merci pour ces nouvelles macros, je l'ai mises , j'obtient un fichier
avec
des images
que l'on peut passer dans un diaporama, d'autant plus que l'on peut
modifier
les dimensions.
Il me reste un problème que j'essaye de résoudre sans résultat en
bricolant
dans la macro
" Creerdesfichiersimages", c'est de remettre les photos avec leur nom
d'origine
plutôt que " Picture "+ numéro d'image Excel + ".jpg". Ce numéro
change
d'ailleurs chaque fois.
Dans la feuille, j'ai une colonne NOMS qui reprend les noms de fichier
photos, les cellules ou j'ai inséré les photos ont elles un Name
identique
au nom de fichier.
J'avoue que j'y perd mon latin.
René

à partir d'une procédure publiée ici par Michel Perron,

Tu exécutes la procédure : Sub CréerDesFichiersImages()
Attention, il y a quelques variables à renseigner :
A ) Chemin : lieu de sauvegare

B ) Tu peux modifier la largeur et la hauteur que l'image aura
dans le fichier image...là.
.Width = 250 'à déterminer
.Height = 175 'à déterminer

C) Ext pour l'extension du fichier.



Dans le haut d'un module standard, déclaration des API
'-------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

'-------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S, Ext
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

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

Sub MakeImgFile(Repertoire As String, S As Shape, Ext As String)

'If TypeName(Selection) = "Range" Then
'If Selection.Areas.Count > 1 Then
'MsgBox " Multiple selections !", 48
'Exit Sub
'End If
'End If
'Selection.CopyPicture 1, 2
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & S.Name & Ext
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub
'-------------------------


Salutations!





"René MATHIEU" a écrit dans le message de
news:
43921d02$0$3641$
bonsoir MichDenis,

Voila, j'ai implanté les deux macros, cela fonctionne très bien, j'ai
ce
que
j'avais demandé.
Mais j'ai fait une grosse erreur en formulant mes demandes (en fait je
n'ai
pas pensé à cela), car comme les photos ont été réduites à la dimension
des
cellules, je récupère dans le nouveau répertoire des fichiers de deux
ou
trois ko, ce qui est trop petit pour le diaporama (et ne peux être
agrandit ).
En fait je dois importer dans de très grandes cellules, puis les
diminuer
pour le traitement (tri sur critères), puis les réagrandir pour la
création
du nouveau répertoire.
De toute faon c'est jouable car c'est pas tout les jours que l'on fait
cela.
Un tout grand merci.
René

"René MATHIEU" a écrit dans le message de
news:
4391eee7$0$10967$
Bonjour,
Grâce à Michdenis qui m'a fournit une macro VBA, j'ai pu transférer
430
photos d'un répertoire du disque c dans une feuille Excel et y
adjoindre
une
série de critères de tri.
Je dois maintenant retransferer après tri ces photos dans un
répertoire
sur
le disque dur.
(Ces photos devraient servir à un diaporama pour un club.)
Est-ce faisable et comment?
Un grand merci d'avance.
René

Bonjour René,

Ton problème ne provient pas de la procédure de conversion des images en fichier que je t'ai transmise hier.

Dans la procédure que tu as utilisée pour charger tes fichiers images dans les cellules, les images insérées ont perdu leur nom
d'origine. La preuve, tes images portent dans ton classeur des noms (image 578) tels que "IMAGE" & UN INDEX que ton classeur
incrémente automatiquement. Lorsque tu appelles ces mêmes images dans une procédure VBA, "IMAGE" se transforme en "PICTURE" suivi de
son index. (Ça, c'est normal pour Excel (!!!!), this is the american way ! En conséquence, il est impossible pour la procédure
transmise hier de retrouver les noms initiaux de tes images. Sur ce type de demande, il y a plus de chance de demander au Pape
(miracle) que d'essayer de trouver une solution à Excel

Solution : explique comment tu charges tes images, où chacune de tes images doivent-elles être chargé dans ton fichier Excel? Le nom
de la feuille. Ont-elles un endroit spécifique (cellule particulière) où elles doivent atterrir (j'espère qu'airbus sait faire!
;-))) selon certains critères?

Si tu me fournis ce type de détails + la procédure que je t'ai transmise sur le sujet, il ne reste plus qu'à la modifier pour
qu'elle corresponde à ce que tu veux faire!

Salutations!



"René MATHIEU" a écrit dans le message de news: 4393f537$0$454$
Bonjour Michel,
La communication, n'est probablement pas mon fort alors voilà

1 - Le répertoire d'origine contient des photos dont les noms sont pour les
deux premiers:
A380.jpg
A380cockpit.jpg
et ainsi de suite.

2 - Dans la feuille de calcul, j'ai dans
la cellule A1 le titre de la colonne
la cellule A2 A380.jpg
la cellule A3 A380cockpit.jpg

3 - la cellule A2 s'appelle A380.jpg
la cellule A3 s'appelle A380cockpit.jpg
les noms de cellule servent au transfert des photos

4 - Les photos une fois chargées s'appellent
en A1 image 578
en A2 image 579
le nombre évoluant chaque fois que l'on transfert les images.

5 - Après transfert des photos, le contenu (sous la photo) et le nom de la
cellule reste inchangé.

6 - Dans le répertoire de transfert d'images, les photos deviennent

Picture 578 alors que je voudrai A380.jpg
Picture 579 alors que je voudrai A380cockpit.jpg

Voila, je ne sais pas en dire plus, mon objectif est de retrouver les mêmes
noms de fichier dans les répertoire d'entrée et de sortie.

amicalement

Écoute, Je ne travaille pas pour le FBI. J'apprécierais si tu faisais un
peu d'effort pour fournir des commentaires qui se tiennent
sans avoir à répéter toujours les mêmes questions. Je ne suis pas dernier
ton écran et je connais pas ton environnement de travail.

QUEL ÉTAIT LE NOM DE TON IMAGE DANS TON CLASSEUR QUI EST DEVENU
PICTURE536?

Si dans le nom de ton image dans tes feuilles de calcul, leur nom avait
une extension .jpg,(d'après une de tes réponses à ma
question) comment expliques-tu que l'extension du fichier ait disparu ?

J'ai re-testé la procédure sous excel 2003 et Windows xp pro, et tout se
passe bien !

À moins que tu aies des observations particulières à communiquer, il m'est
difficile de corriger une situation dont je n'arrive à
pas à reproduire. Ce que tu observes est pour le moins surprenant ! Peut
être que d'autres membres du forum voudront bien tester la
procédure à partir d'une configuration matérielle différente et
confirmeront ou infirmeront tes propos.


Salutations!





"René MATHIEU" a écrit dans le message de news:
43936ae2$0$8835$
Bonsoir,
j'ai bien taper les modifs, vérifier deux fois, ce qui a changé c'est que
maintenant, les fichiers images dans le répertoire sont sous le format:
Picture563, Picture564, etc.
le jpg est parti semble correct car il est enlevé dans la macro Créer
desfichiersimages() à la ligne
MakeImgFile Chemin, S, Ext

Comme le nom des images a déjà l'extension .jpg , j'ai modifié légèrement
la macro.
Je publie l'ensemble pour que ce soit plus facile de t'y retrouver.

Cela devrait rouler... c'était le cas pour mon petit test !

'----------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
'----------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

End Sub

'----------------------------
Sub MakeImgFile(Repertoire As String, S As Shape)
Dim Nom As String
Nom = S.Name
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & Nom
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard

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


Salutations!




"René MATHIEU" a écrit dans le message de news:
43935b06$0$6103$
Bonsoir MichDenis,
merci pour ta réponse, voilà

point A: Dans le répertoire c:airbus
j'ai les fichiers: A380.jpg
A380_cockpit.jpg
A380_fuselage.jpg
"" ""
point B : Nom dans la feuille du classeur = le même que dans le
répertoire,
(obtenu par transfert )

point C : Actuellement pour A380.jpg j'obtiens : Picture532.jpg
pour A380_cockpit j'obtiens
Picture533.jpg et ainsi de suite.
point D : Je voudrai obtenir si c'est possible le nom d'origine, soit
A380.jpg pour la première photo,
a380_cockpit.jpg pour la deuxième , etc...

Informations insuffisantes dans ta présentation de ta problématique.

Prend seulement le cas d'une image....
A )
à l'origine quel le nom + extension du fichier Image que tu insères dans
ta colonne

B ) Quel est le NOM COMPLET de l'image que tu viens tout juste d'insérer
dans le classeur ?

C) A la fin, quand tu transformes l'image en fichier quel est le nom du
fichier + extension ?

D ) Quel nom voudrais-tu qu'il ait ?

P.S. Si tu fais référence au fait que la macro transforme "image 1" et
"Picture 1" , c'est normal pour excel, il travaille en VBA,
et là c'est Américain (en anglais) . Excel fait la transformation tout
seul. Quelle gentillesse ? Cependant, ceci se résout
facilement.


Salutations!




"René MATHIEU" a écrit dans le message de news:
43934824$0$31129$
Bonjour,
Merci pour ces nouvelles macros, je l'ai mises , j'obtient un fichier
avec
des images
que l'on peut passer dans un diaporama, d'autant plus que l'on peut
modifier
les dimensions.
Il me reste un problème que j'essaye de résoudre sans résultat en
bricolant
dans la macro
" Creerdesfichiersimages", c'est de remettre les photos avec leur nom
d'origine
plutôt que " Picture "+ numéro d'image Excel + ".jpg". Ce numéro
change
d'ailleurs chaque fois.
Dans la feuille, j'ai une colonne NOMS qui reprend les noms de fichier
photos, les cellules ou j'ai inséré les photos ont elles un Name
identique
au nom de fichier.
J'avoue que j'y perd mon latin.
René

à partir d'une procédure publiée ici par Michel Perron,

Tu exécutes la procédure : Sub CréerDesFichiersImages()
Attention, il y a quelques variables à renseigner :
A ) Chemin : lieu de sauvegare

B ) Tu peux modifier la largeur et la hauteur que l'image aura
dans le fichier image...là.
.Width = 250 'à déterminer
.Height = 175 'à déterminer

C) Ext pour l'extension du fichier.



Dans le haut d'un module standard, déclaration des API
'-------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

'-------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S, Ext
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

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

Sub MakeImgFile(Repertoire As String, S As Shape, Ext As String)

'If TypeName(Selection) = "Range" Then
'If Selection.Areas.Count > 1 Then
'MsgBox " Multiple selections !", 48
'Exit Sub
'End If
'End If
'Selection.CopyPicture 1, 2
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & S.Name & Ext
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub
'-------------------------


Salutations!





"René MATHIEU" a écrit dans le message de
news:
43921d02$0$3641$
bonsoir MichDenis,

Voila, j'ai implanté les deux macros, cela fonctionne très bien, j'ai
ce
que
j'avais demandé.
Mais j'ai fait une grosse erreur en formulant mes demandes (en fait je
n'ai
pas pensé à cela), car comme les photos ont été réduites à la dimension
des
cellules, je récupère dans le nouveau répertoire des fichiers de deux
ou
trois ko, ce qui est trop petit pour le diaporama (et ne peux être
agrandit ).
En fait je dois importer dans de très grandes cellules, puis les
diminuer
pour le traitement (tri sur critères), puis les réagrandir pour la
création
du nouveau répertoire.
De toute faon c'est jouable car c'est pas tout les jours que l'on fait
cela.
Un tout grand merci.
René

"René MATHIEU" a écrit dans le message de
news:
4391eee7$0$10967$
Bonjour,
Grâce à Michdenis qui m'a fournit une macro VBA, j'ai pu transférer
430
photos d'un répertoire du disque c dans une feuille Excel et y
adjoindre
une
série de critères de tri.
Je dois maintenant retransferer après tri ces photos dans un
répertoire
sur
le disque dur.
(Ces photos devraient servir à un diaporama pour un club.)
Est-ce faisable et comment?
Un grand merci d'avance.
René

Bonsoir,

Je n'avais pas vu que le nom des photos avait déjà changé lors de leur
transfert dans la feuille,
je n'ai vu cela que hier soir en cliquant sur une image

voila, la petite procedure que j' utilise actuellement,

1 - A partir du répertoire C:Airbus, je crée un fichier "Listing.txt"
comprenant le nom de toutes les photos.
Je copie ce fichier dans la colonne A d'une feuille Excel nommée Feuil1.
J'ai alors en A1 A380.,jpg
en A2 A380_cockpit.jpg
etc...
2 - J' ai une petite macro qui "nomme" les cellules avec le nom qui est dans
la cellule
donc en A1 j'ai A380.jpg et la cellule se nomme A380.jpg, idem pour
toutes les cellules
de la col. A non vide.

3 - j'utilise les macros que tu m'as envoyés TestMonImage et InsereImage.
Je les ai modifiées pour régler les dimensions des cellules avant et
après transfert.

4 - Les autres col. de la feuilles contiennent, des noms, des numéros de
série, des dates,etc...
qui serviront de critères de tri.

voila, j'espere que c'est complet

ci dessous les deux macros utilisées.

Sub TestMonImage()
Dim Img As String
Dim RepImage As String
Dim n As Name
Dim Rg As Range
Dim cellule As Range
Dim reponse As String
'---------------------------------------------------------------
' donner le répertoire ou se trouve les fichiers images qui sont en xxxx.jpg
' à la ligne ci dessous.
'---------------------------------------------------------------
RepImage = "c:Documents and SettingsRenéMes documentsairbus"

On Error Resume Next
With ActiveSheet.Cells
Selection.ColumnWidth = 70 'Réglage de la largeur des colonnes à
l'importation
Selection.RowHeight = 350 'Réglage de la hauteur des colonnes à
l'importation
End With

For Each n In Application.Names 'recherche des noms inscrits dans les
cellules
Set Rg = Range(n.Name) ' et présélectionnés manuellement.
If Err <> 0 Then
Err = 0
Else
If LCase(Right(n.Name, 4)) <> ".jpg" Then
Img = RepImage & n.Name & ".jpg"
Else
Img = RepImage & n.Name
End If
If Dir(Img) <> "" Then
InsererImage Rg.Parent.Name, Rg, Img 'aller à la macro pour importer les
images
Else
reponse = MsgBox("ce fichier image n'existe pas ou vous n'avez pas
sélectionner :oui pour arreter, non pour continuer" & _
vbCrLf & Img, vbYesNo)
If reponse = vbYes Then GoTo Suite Else
End If

End If
Next

Suite:
Cells.Select
Selection.ColumnWidth = 14 'on remet les images dans les dimensions
réduites
Selection.RowHeight = 70 ' pour travailler sur la feuille, ex. tri
Range("a1").Select
End Sub

'-------------------------------------------------------------------------
Sub InsererImage(feuille As String, ByVal Rg As Range, NomImage As String)
Dim Largeur As Double
Dim Hauteur As Double
Dim Image As Object

With Worksheets(feuille)
Largeur = Rg.Offset(, 1)(, Rg.Columns.Count).Left - Rg.Left
Hauteur = Rg.Offset(Rg.Rows.Count).Top - Rg(1).Top
Set Image = .Pictures.Insert(NomImage)
End With
With Image
.Left = Rg.Left + 0.01
.Top = Rg.Top + 0.01
'Largeur de l'image = largeur - 0.01
Image.Width = Largeur - 0.01
'Hauteur de l'image
Image.Height = Hauteur - 0.01
'l'image doit se déplacer avec les cellules
.Placement = xlMoveAndSize
'note, possibilité xlmove et freefloating
'verrouillé ou pas par true ou false
.Locked = True
End With
Set Rg = Nothing

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

Ton problème ne provient pas de la procédure de conversion des images en
fichier que je t'ai transmise hier.

Dans la procédure que tu as utilisée pour charger tes fichiers images dans
les cellules, les images insérées ont perdu leur nom
d'origine. La preuve, tes images portent dans ton classeur des noms (image
578) tels que "IMAGE" & UN INDEX que ton classeur
incrémente automatiquement. Lorsque tu appelles ces mêmes images dans une
procédure VBA, "IMAGE" se transforme en "PICTURE" suivi de
son index. (Ça, c'est normal pour Excel (!!!!), this is the american way !
En conséquence, il est impossible pour la procédure
transmise hier de retrouver les noms initiaux de tes images. Sur ce type
de demande, il y a plus de chance de demander au Pape
(miracle) que d'essayer de trouver une solution à Excel

Solution : explique comment tu charges tes images, où chacune de tes
images doivent-elles être chargé dans ton fichier Excel? Le nom
de la feuille. Ont-elles un endroit spécifique (cellule particulière) où
elles doivent atterrir (j'espère qu'airbus sait faire!
;-))) selon certains critères?

Si tu me fournis ce type de détails + la procédure que je t'ai transmise
sur le sujet, il ne reste plus qu'à la modifier pour
qu'elle corresponde à ce que tu veux faire!

Salutations!



"René MATHIEU" a écrit dans le message de news:
4393f537$0$454$
Bonjour Michel,
La communication, n'est probablement pas mon fort alors voilà

1 - Le répertoire d'origine contient des photos dont les noms sont pour
les
deux premiers:
A380.jpg
A380cockpit.jpg
et ainsi de suite.

2 - Dans la feuille de calcul, j'ai dans
la cellule A1 le titre de la colonne
la cellule A2 A380.jpg
la cellule A3 A380cockpit.jpg

3 - la cellule A2 s'appelle A380.jpg
la cellule A3 s'appelle A380cockpit.jpg
les noms de cellule servent au transfert des photos

4 - Les photos une fois chargées s'appellent
en A1 image 578
en A2 image 579
le nombre évoluant chaque fois que l'on transfert les images.

5 - Après transfert des photos, le contenu (sous la photo) et le nom de
la
cellule reste inchangé.

6 - Dans le répertoire de transfert d'images, les photos deviennent

Picture 578 alors que je voudrai A380.jpg
Picture 579 alors que je voudrai A380cockpit.jpg

Voila, je ne sais pas en dire plus, mon objectif est de retrouver les
mêmes
noms de fichier dans les répertoire d'entrée et de sortie.

amicalement

Écoute, Je ne travaille pas pour le FBI. J'apprécierais si tu faisais un
peu d'effort pour fournir des commentaires qui se tiennent
sans avoir à répéter toujours les mêmes questions. Je ne suis pas dernier
ton écran et je connais pas ton environnement de travail.

QUEL ÉTAIT LE NOM DE TON IMAGE DANS TON CLASSEUR QUI EST DEVENU
PICTURE536?

Si dans le nom de ton image dans tes feuilles de calcul, leur nom avait
une extension .jpg,(d'après une de tes réponses à ma
question) comment expliques-tu que l'extension du fichier ait disparu ?

J'ai re-testé la procédure sous excel 2003 et Windows xp pro, et tout se
passe bien !

À moins que tu aies des observations particulières à communiquer, il
m'est
difficile de corriger une situation dont je n'arrive à
pas à reproduire. Ce que tu observes est pour le moins surprenant ! Peut
être que d'autres membres du forum voudront bien tester la
procédure à partir d'une configuration matérielle différente et
confirmeront ou infirmeront tes propos.


Salutations!





"René MATHIEU" a écrit dans le message de news:
43936ae2$0$8835$
Bonsoir,
j'ai bien taper les modifs, vérifier deux fois, ce qui a changé c'est que
maintenant, les fichiers images dans le répertoire sont sous le format:
Picture563, Picture564, etc.
le jpg est parti semble correct car il est enlevé dans la macro Créer
desfichiersimages() à la ligne
MakeImgFile Chemin, S, Ext

Comme le nom des images a déjà l'extension .jpg , j'ai modifié
légèrement
la macro.
Je publie l'ensemble pour que ce soit plus facile de t'y retrouver.

Cela devrait rouler... c'était le cas pour mon petit test !

'----------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
'----------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

End Sub

'----------------------------
Sub MakeImgFile(Repertoire As String, S As Shape)
Dim Nom As String
Nom = S.Name
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & Nom
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard

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


Salutations!




"René MATHIEU" a écrit dans le message de news:
43935b06$0$6103$
Bonsoir MichDenis,
merci pour ta réponse, voilà

point A: Dans le répertoire c:airbus
j'ai les fichiers: A380.jpg
A380_cockpit.jpg
A380_fuselage.jpg
"" ""
point B : Nom dans la feuille du classeur = le même que dans le
répertoire,
(obtenu par transfert )

point C : Actuellement pour A380.jpg j'obtiens :
Picture532.jpg
pour A380_cockpit j'obtiens
Picture533.jpg et ainsi de suite.
point D : Je voudrai obtenir si c'est possible le nom d'origine, soit
A380.jpg pour la première photo,
a380_cockpit.jpg pour la deuxième , etc...

Informations insuffisantes dans ta présentation de ta problématique.

Prend seulement le cas d'une image....
A )
à l'origine quel le nom + extension du fichier Image que tu insères
dans
ta colonne

B ) Quel est le NOM COMPLET de l'image que tu viens tout juste
d'insérer
dans le classeur ?

C) A la fin, quand tu transformes l'image en fichier quel est le nom du
fichier + extension ?

D ) Quel nom voudrais-tu qu'il ait ?

P.S. Si tu fais référence au fait que la macro transforme "image 1" et
"Picture 1" , c'est normal pour excel, il travaille en VBA,
et là c'est Américain (en anglais) . Excel fait la transformation tout
seul. Quelle gentillesse ? Cependant, ceci se résout
facilement.


Salutations!




"René MATHIEU" a écrit dans le message de
news:
43934824$0$31129$
Bonjour,
Merci pour ces nouvelles macros, je l'ai mises , j'obtient un fichier
avec
des images
que l'on peut passer dans un diaporama, d'autant plus que l'on peut
modifier
les dimensions.
Il me reste un problème que j'essaye de résoudre sans résultat en
bricolant
dans la macro
" Creerdesfichiersimages", c'est de remettre les photos avec leur nom
d'origine
plutôt que " Picture "+ numéro d'image Excel + ".jpg". Ce numéro
change
d'ailleurs chaque fois.
Dans la feuille, j'ai une colonne NOMS qui reprend les noms de fichier
photos, les cellules ou j'ai inséré les photos ont elles un Name
identique
au nom de fichier.
J'avoue que j'y perd mon latin.
René

à partir d'une procédure publiée ici par Michel Perron,

Tu exécutes la procédure : Sub CréerDesFichiersImages()
Attention, il y a quelques variables à renseigner :
A ) Chemin : lieu de sauvegare

B ) Tu peux modifier la largeur et la hauteur que l'image aura
dans le fichier image...là.
.Width = 250 'à déterminer
.Height = 175 'à déterminer

C) Ext pour l'extension du fichier.



Dans le haut d'un module standard, déclaration des API
'-------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

'-------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S, Ext
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

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

Sub MakeImgFile(Repertoire As String, S As Shape, Ext As String)

'If TypeName(Selection) = "Range" Then
'If Selection.Areas.Count > 1 Then
'MsgBox " Multiple selections !", 48
'Exit Sub
'End If
'End If
'Selection.CopyPicture 1, 2
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & S.Name & Ext
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub
'-------------------------


Salutations!





"René MATHIEU" a écrit dans le message de
news:
43921d02$0$3641$
bonsoir MichDenis,

Voila, j'ai implanté les deux macros, cela fonctionne très bien, j'ai
ce
que
j'avais demandé.
Mais j'ai fait une grosse erreur en formulant mes demandes (en fait je
n'ai
pas pensé à cela), car comme les photos ont été réduites à la
dimension
des
cellules, je récupère dans le nouveau répertoire des fichiers de deux
ou
trois ko, ce qui est trop petit pour le diaporama (et ne peux être
agrandit ).
En fait je dois importer dans de très grandes cellules, puis les
diminuer
pour le traitement (tri sur critères), puis les réagrandir pour la
création
du nouveau répertoire.
De toute faon c'est jouable car c'est pas tout les jours que l'on fait
cela.
Un tout grand merci.
René

"René MATHIEU" a écrit dans le message de
news:
4391eee7$0$10967$
Bonjour,
Grâce à Michdenis qui m'a fournit une macro VBA, j'ai pu transférer
430
photos d'un répertoire du disque c dans une feuille Excel et y
adjoindre
une
série de critères de tri.
Je dois maintenant retransferer après tri ces photos dans un
répertoire
sur
le disque dur.
(Ces photos devraient servir à un diaporama pour un club.)
Est-ce faisable et comment?
Un grand merci d'avance.
René

Un dernier détail important, les images doivent attérir dans quelle colonne ?
dans la colonne A où il y a leur nom ou dans une autre colonne ?


Salutations!


"René MATHIEU" a écrit dans le message de news: 43947483$0$2144$
Bonsoir,

Je n'avais pas vu que le nom des photos avait déjà changé lors de leur
transfert dans la feuille,
je n'ai vu cela que hier soir en cliquant sur une image

voila, la petite procedure que j' utilise actuellement,

1 - A partir du répertoire C:Airbus, je crée un fichier "Listing.txt"
comprenant le nom de toutes les photos.
Je copie ce fichier dans la colonne A d'une feuille Excel nommée Feuil1.
J'ai alors en A1 A380.,jpg
en A2 A380_cockpit.jpg
etc...
2 - J' ai une petite macro qui "nomme" les cellules avec le nom qui est dans
la cellule
donc en A1 j'ai A380.jpg et la cellule se nomme A380.jpg, idem pour
toutes les cellules
de la col. A non vide.

3 - j'utilise les macros que tu m'as envoyés TestMonImage et InsereImage.
Je les ai modifiées pour régler les dimensions des cellules avant et
après transfert.

4 - Les autres col. de la feuilles contiennent, des noms, des numéros de
série, des dates,etc...
qui serviront de critères de tri.

voila, j'espere que c'est complet

ci dessous les deux macros utilisées.

Sub TestMonImage()
Dim Img As String
Dim RepImage As String
Dim n As Name
Dim Rg As Range
Dim cellule As Range
Dim reponse As String
'---------------------------------------------------------------
' donner le répertoire ou se trouve les fichiers images qui sont en xxxx.jpg
' à la ligne ci dessous.
'---------------------------------------------------------------
RepImage = "c:Documents and SettingsRenéMes documentsairbus"

On Error Resume Next
With ActiveSheet.Cells
Selection.ColumnWidth = 70 'Réglage de la largeur des colonnes à
l'importation
Selection.RowHeight = 350 'Réglage de la hauteur des colonnes à
l'importation
End With

For Each n In Application.Names 'recherche des noms inscrits dans les
cellules
Set Rg = Range(n.Name) ' et présélectionnés manuellement.
If Err <> 0 Then
Err = 0
Else
If LCase(Right(n.Name, 4)) <> ".jpg" Then
Img = RepImage & n.Name & ".jpg"
Else
Img = RepImage & n.Name
End If
If Dir(Img) <> "" Then
InsererImage Rg.Parent.Name, Rg, Img 'aller à la macro pour importer les
images
Else
reponse = MsgBox("ce fichier image n'existe pas ou vous n'avez pas
sélectionner :oui pour arreter, non pour continuer" & _
vbCrLf & Img, vbYesNo)
If reponse = vbYes Then GoTo Suite Else
End If

End If
Next

Suite:
Cells.Select
Selection.ColumnWidth = 14 'on remet les images dans les dimensions
réduites
Selection.RowHeight = 70 ' pour travailler sur la feuille, ex. tri
Range("a1").Select
End Sub

'-------------------------------------------------------------------------
Sub InsererImage(feuille As String, ByVal Rg As Range, NomImage As String)
Dim Largeur As Double
Dim Hauteur As Double
Dim Image As Object

With Worksheets(feuille)
Largeur = Rg.Offset(, 1)(, Rg.Columns.Count).Left - Rg.Left
Hauteur = Rg.Offset(Rg.Rows.Count).Top - Rg(1).Top
Set Image = .Pictures.Insert(NomImage)
End With
With Image
.Left = Rg.Left + 0.01
.Top = Rg.Top + 0.01
'Largeur de l'image = largeur - 0.01
Image.Width = Largeur - 0.01
'Hauteur de l'image
Image.Height = Hauteur - 0.01
'l'image doit se déplacer avec les cellules
.Placement = xlMoveAndSize
'note, possibilité xlmove et freefloating
'verrouillé ou pas par true ou false
.Locked = True
End With
Set Rg = Nothing

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

Ton problème ne provient pas de la procédure de conversion des images en
fichier que je t'ai transmise hier.

Dans la procédure que tu as utilisée pour charger tes fichiers images dans
les cellules, les images insérées ont perdu leur nom
d'origine. La preuve, tes images portent dans ton classeur des noms (image
578) tels que "IMAGE" & UN INDEX que ton classeur
incrémente automatiquement. Lorsque tu appelles ces mêmes images dans une
procédure VBA, "IMAGE" se transforme en "PICTURE" suivi de
son index. (Ça, c'est normal pour Excel (!!!!), this is the american way !
En conséquence, il est impossible pour la procédure
transmise hier de retrouver les noms initiaux de tes images. Sur ce type
de demande, il y a plus de chance de demander au Pape
(miracle) que d'essayer de trouver une solution à Excel

Solution : explique comment tu charges tes images, où chacune de tes
images doivent-elles être chargé dans ton fichier Excel? Le nom
de la feuille. Ont-elles un endroit spécifique (cellule particulière) où
elles doivent atterrir (j'espère qu'airbus sait faire!
;-))) selon certains critères?

Si tu me fournis ce type de détails + la procédure que je t'ai transmise
sur le sujet, il ne reste plus qu'à la modifier pour
qu'elle corresponde à ce que tu veux faire!

Salutations!



"René MATHIEU" a écrit dans le message de news:
4393f537$0$454$
Bonjour Michel,
La communication, n'est probablement pas mon fort alors voilà

1 - Le répertoire d'origine contient des photos dont les noms sont pour
les
deux premiers:
A380.jpg
A380cockpit.jpg
et ainsi de suite.

2 - Dans la feuille de calcul, j'ai dans
la cellule A1 le titre de la colonne
la cellule A2 A380.jpg
la cellule A3 A380cockpit.jpg

3 - la cellule A2 s'appelle A380.jpg
la cellule A3 s'appelle A380cockpit.jpg
les noms de cellule servent au transfert des photos

4 - Les photos une fois chargées s'appellent
en A1 image 578
en A2 image 579
le nombre évoluant chaque fois que l'on transfert les images.

5 - Après transfert des photos, le contenu (sous la photo) et le nom de
la
cellule reste inchangé.

6 - Dans le répertoire de transfert d'images, les photos deviennent

Picture 578 alors que je voudrai A380.jpg
Picture 579 alors que je voudrai A380cockpit.jpg

Voila, je ne sais pas en dire plus, mon objectif est de retrouver les
mêmes
noms de fichier dans les répertoire d'entrée et de sortie.

amicalement

Écoute, Je ne travaille pas pour le FBI. J'apprécierais si tu faisais un
peu d'effort pour fournir des commentaires qui se tiennent
sans avoir à répéter toujours les mêmes questions. Je ne suis pas dernier
ton écran et je connais pas ton environnement de travail.

QUEL ÉTAIT LE NOM DE TON IMAGE DANS TON CLASSEUR QUI EST DEVENU
PICTURE536?

Si dans le nom de ton image dans tes feuilles de calcul, leur nom avait
une extension .jpg,(d'après une de tes réponses à ma
question) comment expliques-tu que l'extension du fichier ait disparu ?

J'ai re-testé la procédure sous excel 2003 et Windows xp pro, et tout se
passe bien !

À moins que tu aies des observations particulières à communiquer, il
m'est
difficile de corriger une situation dont je n'arrive à
pas à reproduire. Ce que tu observes est pour le moins surprenant ! Peut
être que d'autres membres du forum voudront bien tester la
procédure à partir d'une configuration matérielle différente et
confirmeront ou infirmeront tes propos.


Salutations!





"René MATHIEU" a écrit dans le message de news:
43936ae2$0$8835$
Bonsoir,
j'ai bien taper les modifs, vérifier deux fois, ce qui a changé c'est que
maintenant, les fichiers images dans le répertoire sont sous le format:
Picture563, Picture564, etc.
le jpg est parti semble correct car il est enlevé dans la macro Créer
desfichiersimages() à la ligne
MakeImgFile Chemin, S, Ext

Comme le nom des images a déjà l'extension .jpg , j'ai modifié
légèrement
la macro.
Je publie l'ensemble pour que ce soit plus facile de t'y retrouver.

Cela devrait rouler... c'était le cas pour mon petit test !

'----------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type
'----------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

End Sub

'----------------------------
Sub MakeImgFile(Repertoire As String, S As Shape)
Dim Nom As String
Nom = S.Name
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & Nom
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard

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


Salutations!




"René MATHIEU" a écrit dans le message de news:
43935b06$0$6103$
Bonsoir MichDenis,
merci pour ta réponse, voilà

point A: Dans le répertoire c:airbus
j'ai les fichiers: A380.jpg
A380_cockpit.jpg
A380_fuselage.jpg
"" ""
point B : Nom dans la feuille du classeur = le même que dans le
répertoire,
(obtenu par transfert )

point C : Actuellement pour A380.jpg j'obtiens :
Picture532.jpg
pour A380_cockpit j'obtiens
Picture533.jpg et ainsi de suite.
point D : Je voudrai obtenir si c'est possible le nom d'origine, soit
A380.jpg pour la première photo,
a380_cockpit.jpg pour la deuxième , etc...

Informations insuffisantes dans ta présentation de ta problématique.

Prend seulement le cas d'une image....
A )
à l'origine quel le nom + extension du fichier Image que tu insères
dans
ta colonne

B ) Quel est le NOM COMPLET de l'image que tu viens tout juste
d'insérer
dans le classeur ?

C) A la fin, quand tu transformes l'image en fichier quel est le nom du
fichier + extension ?

D ) Quel nom voudrais-tu qu'il ait ?

P.S. Si tu fais référence au fait que la macro transforme "image 1" et
"Picture 1" , c'est normal pour excel, il travaille en VBA,
et là c'est Américain (en anglais) . Excel fait la transformation tout
seul. Quelle gentillesse ? Cependant, ceci se résout
facilement.


Salutations!




"René MATHIEU" a écrit dans le message de
news:
43934824$0$31129$
Bonjour,
Merci pour ces nouvelles macros, je l'ai mises , j'obtient un fichier
avec
des images
que l'on peut passer dans un diaporama, d'autant plus que l'on peut
modifier
les dimensions.
Il me reste un problème que j'essaye de résoudre sans résultat en
bricolant
dans la macro
" Creerdesfichiersimages", c'est de remettre les photos avec leur nom
d'origine
plutôt que " Picture "+ numéro d'image Excel + ".jpg". Ce numéro
change
d'ailleurs chaque fois.
Dans la feuille, j'ai une colonne NOMS qui reprend les noms de fichier
photos, les cellules ou j'ai inséré les photos ont elles un Name
identique
au nom de fichier.
J'avoue que j'y perd mon latin.
René

à partir d'une procédure publiée ici par Michel Perron,

Tu exécutes la procédure : Sub CréerDesFichiersImages()
Attention, il y a quelques variables à renseigner :
A ) Chemin : lieu de sauvegare

B ) Tu peux modifier la largeur et la hauteur que l'image aura
dans le fichier image...là.
.Width = 250 'à déterminer
.Height = 175 'à déterminer

C) Ext pour l'extension du fichier.



Dans le haut d'un module standard, déclaration des API
'-------------------------
Option Explicit
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function CopyImage& Lib "user32" (ByVal handle& _
, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function GetClipboardData Lib "user32" _
(ByVal wFormat As Long) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long _
, ByRef ppvObj As IPicture) As Long

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

'-------------------------
Sub CréerDesFichiersImages()

Dim sh As Worksheet
Dim S As Shape, Chemin As String
Dim T As Double, L As Double
Dim H As Double, W As Double
Dim Ext As String

'répertoire où seront copiés les images
Chemin = "c:" 'à définir
'L'extension du fichier
Ext = ".jpg"
Application.ScreenUpdating = False
With ThisWorkbook
For Each sh In .Worksheets
For Each S In sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
With S
T = .Top
L = .Left
H = .Height
W = .Width
.Width = 250 'à déterminer
.Height = 175 'à déterminer
MakeImgFile Chemin, S, Ext
.Top = T
.Left = L
.Height = H
.Width = W
End With
End If
Next
Next
End With
Set sh = Nothing: Set S = Nothing

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

Sub MakeImgFile(Repertoire As String, S As Shape, Ext As String)

'If TypeName(Selection) = "Range" Then
'If Selection.Areas.Count > 1 Then
'MsgBox " Multiple selections !", 48
'Exit Sub
'End If
'End If
'Selection.CopyPicture 1, 2
S.CopyPicture 1, 2
Dim hCopy&: OpenClipboard 0&
If IsClipboardFormatAvailable(2) = 0 Then GoTo 1
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
If hCopy = 0 Then GoTo 1
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim iPic As IPicture, ID As GUID, PCT As PICTDESC, Ret As Long
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), ID)
If Ret Then GoTo 1
With PCT
.cbSize = Len(PCT)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(PCT, ID, 1, iPic)
If Ret Then GoTo 1
' Sauve l'image sur le disque (format bmp)
SavePicture iPic, Repertoire & S.Name & Ext
Set iPic = Nothing
1: EmptyClipboard
CloseClipboard
End Sub
'-------------------------


Salutations!





"René MATHIEU" a écrit dans le message de
news:
43921d02$0$3641$
bonsoir MichDenis,

Voila, j'ai implanté les deux macros, cela fonctionne très bien, j'ai
ce
que
j'avais demandé.
Mais j'ai fait une grosse erreur en formulant mes demandes (en fait je
n'ai
pas pensé à cela), car comme les photos ont été réduites à la
dimension
des
cellules, je récupère dans le nouveau répertoire des fichiers de deux
ou
trois ko, ce qui est trop petit pour le diaporama (et ne peux être
agrandit ).
En fait je dois importer dans de très grandes cellules, puis les
diminuer
pour le traitement (tri sur critères), puis les réagrandir pour la
création
du nouveau répertoire.
De toute faon c'est jouable car c'est pas tout les jours que l'on fait
cela.
Un tout grand merci.
René

"René MATHIEU" a écrit dans le message de
news:
4391eee7$0$10967$
Bonjour,
Grâce à Michdenis qui m'a fournit une macro VBA, j'ai pu transférer
430
photos d'un répertoire du disque c dans une feuille Excel et y
adjoindre
une
série de critères de tri.
Je dois maintenant retransferer après tri ces photos dans un
répertoire
sur
le disque dur.
(Ces photos devraient servir à un diaporama pour un club.)
Est-ce faisable et comment?
Un grand merci d'avance.
René