Je suis heureux que tu aies réussi à transférer 430 images ... comme je
suis payé à l'unité
tu vas avoir une surprise !!! ;-)
Et pour doubler la mise, copie les 2 procédures suivantes dans le classeur
où sont tes images.
Ces procédures vont transformer ces images en fichier vers un répertoire
que tu vas
toi même désigner. Le nom de chaque fichier image recevra le nom de
l'image dans ton
fichier + l'extension PNG ... si tu préféres JPG, tu n'as qu'à modifier
cette ligne de code:
" .Chart.Export Repertoire & S.Name & ".png", "PNG"
Ceci est valide pour TOUTES LES IMAGES de toutes les feuilles de ton
classeur.
'---------------------------------------
Sub CréerDesFichiersImages()
Dim Wk As Workbook, Sh As Worksheet
Dim S As Shape
Application.ScreenUpdating = False
Set Wk = Workbooks.Add
With ThisWorkbook
For Each Sh In .Worksheets
For Each S In Sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
ImageVersFichier Wk, S, "c:"
End If
Next
Next
End With
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'---------------------------------------
Sub ImageVersFichier(Wk As Workbook, S As Shape, _
Repertoire As String)
S.CopyPicture
With Wk
With .Sheets(1)
.Paste
With .ChartObjects.Add(0, 0, _
S.Width, S.Height).Chart
.Paste
.ChartArea.Border.LineStyle = 0
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export Repertoire & S.Name & ".png", "PNG"
Selection.Delete
.Delete
End With
End With
End With
End Sub
'---------------------------------------
Salutations!
"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é
Je suis heureux que tu aies réussi à transférer 430 images ... comme je
suis payé à l'unité
tu vas avoir une surprise !!! ;-)
Et pour doubler la mise, copie les 2 procédures suivantes dans le classeur
où sont tes images.
Ces procédures vont transformer ces images en fichier vers un répertoire
que tu vas
toi même désigner. Le nom de chaque fichier image recevra le nom de
l'image dans ton
fichier + l'extension PNG ... si tu préféres JPG, tu n'as qu'à modifier
cette ligne de code:
" .Chart.Export Repertoire & S.Name & ".png", "PNG"
Ceci est valide pour TOUTES LES IMAGES de toutes les feuilles de ton
classeur.
'---------------------------------------
Sub CréerDesFichiersImages()
Dim Wk As Workbook, Sh As Worksheet
Dim S As Shape
Application.ScreenUpdating = False
Set Wk = Workbooks.Add
With ThisWorkbook
For Each Sh In .Worksheets
For Each S In Sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
ImageVersFichier Wk, S, "c:"
End If
Next
Next
End With
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'---------------------------------------
Sub ImageVersFichier(Wk As Workbook, S As Shape, _
Repertoire As String)
S.CopyPicture
With Wk
With .Sheets(1)
.Paste
With .ChartObjects.Add(0, 0, _
S.Width, S.Height).Chart
.Paste
.ChartArea.Border.LineStyle = 0
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export Repertoire & S.Name & ".png", "PNG"
Selection.Delete
.Delete
End With
End With
End With
End Sub
'---------------------------------------
Salutations!
"René MATHIEU" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
Je suis heureux que tu aies réussi à transférer 430 images ... comme je
suis payé à l'unité
tu vas avoir une surprise !!! ;-)
Et pour doubler la mise, copie les 2 procédures suivantes dans le classeur
où sont tes images.
Ces procédures vont transformer ces images en fichier vers un répertoire
que tu vas
toi même désigner. Le nom de chaque fichier image recevra le nom de
l'image dans ton
fichier + l'extension PNG ... si tu préféres JPG, tu n'as qu'à modifier
cette ligne de code:
" .Chart.Export Repertoire & S.Name & ".png", "PNG"
Ceci est valide pour TOUTES LES IMAGES de toutes les feuilles de ton
classeur.
'---------------------------------------
Sub CréerDesFichiersImages()
Dim Wk As Workbook, Sh As Worksheet
Dim S As Shape
Application.ScreenUpdating = False
Set Wk = Workbooks.Add
With ThisWorkbook
For Each Sh In .Worksheets
For Each S In Sh.Shapes
If TypeName(S.OLEFormat.Object) = "Picture" Then
ImageVersFichier Wk, S, "c:"
End If
Next
Next
End With
Wk.Close False
Set Wk = Nothing: Set Sh = Nothing: Set S = Nothing
End Sub
'---------------------------------------
Sub ImageVersFichier(Wk As Workbook, S As Shape, _
Repertoire As String)
S.CopyPicture
With Wk
With .Sheets(1)
.Paste
With .ChartObjects.Add(0, 0, _
S.Width, S.Height).Chart
.Paste
.ChartArea.Border.LineStyle = 0
End With
With .ChartObjects(1)
.Top = 0
.Left = 0
.Chart.Export Repertoire & S.Name & ".png", "PNG"
Selection.Delete
.Delete
End With
End With
End With
End Sub
'---------------------------------------
Salutations!
"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é
"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é
"René MATHIEU" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
"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é
"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é
"René MATHIEU" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
"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é
à 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é
à 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" <mathieu.rene@skynet.be> a écrit dans le message de news:
43921d02$0$3641$ba620e4c@news.skynet.be...
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
à 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é
à 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é
à 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" <mathieu.rene@skynet.be> a écrit dans le message de news:
43921d02$0$3641$ba620e4c@news.skynet.be...
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
à 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é
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é
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
43934824$0$31129$ba620e4c@news.skynet.be...
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
43921d02$0$3641$ba620e4c@news.skynet.be...
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
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é
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é
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
43934824$0$31129$ba620e4c@news.skynet.be...
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
43921d02$0$3641$ba620e4c@news.skynet.be...
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" <mathieu.rene@skynet.be> a écrit dans le message de news:
4391eee7$0$10967$ba620e4c@news.skynet.be...
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é
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é
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!
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!
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!
