Je possède une macro qui inscrit un lien hypertexte chaque fois qu'il trouve
une image correspondante dans un répertoire donné, puis dans une autre
colonne donne ses dimensions en pixels.
J'aimerai maintenant afficher (dans une autre cellule) la vignette de
l'image correspondante (taille d'origine parfois 2500px !). Voir je possède
aussi un autre répertoire où ses images sont optimisées en 60 ou 65px.
Pouvez-vous me guider pas à pas sachant que je ne connais rien de vba ?
J'aimerais avoir une macro indépendante sinon voici l'existante :
Sub xxx()
'Dans outil réferences cocher Microsoft Shell Controls and Automation
Dim Nom_Image As Variant
Nom_Image = ActiveCell.Value
Dim comp As Variant
Dim Nom_fichier_image As Variant
Dim myShell As Shell
Dim myFolder As Folder
Dim myFile As FolderItem
'Déclaration de la variable récupérant le texte de la cellule pour aller
'chercher l 'image correspondante
' Exécute la boucle jusqu'à la première cellule vide
'Chemin = ThisWorkbook.Path
Chemin = "C:\Prod\Web_2008\Visuels_fin\Small_65x65\"
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(Chemin)
Do Until Nom_Image = ""
' la variable sera égale à la valeur de la cellule active
fich = Dir(Chemin & "\" & Nom_Image)
If fich <> "" Then
With ActiveCell
.Hyperlinks.Add .Range("A1"), Chemin & "\" & Nom_Image
Set myFile = myFolder.Items.Item(fich)
ActiveCell.Offset(0, 1) = myFolder.GetDetailsOf(myFile, 26)
ActiveCell.Offset(1, 0).Select
End With
Else
ActiveCell.Offset(0, 1) = Nom_Image & "pas trouvé"
ActiveCell.Offset(1, 0).Select
End If
' la variable est initialisée avec la nouvelle valeur de la cellule Active
Nom_Image = ActiveCell.Value
Set Nom_fichier_image = Nothing
Loop
End Sub
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
PMO
Bonjour,
Une piste avec le code ci-dessous.
J'ai été obligé de modifier votre sub xxx. Par conséquent et par précaution, veuillez faire un test sur une COPIE de votre classeur. La macro part IMPERATIVEMENT de la cellule A1. Veuillez renseigner le nom de vos photos à partir de A1. J'ai fait les tests sur Excel 2002.
D'autre part, si vous exécutez le code en mode "Pas à pas détaillé", il faut faire attention à l'exécution de la sub "CompressionImage" car elle contient une instruction "Application.SendKeys" qui risque de s'appliquer dans la fenêtre de code.
CELA FAIT 1) reprise du traitement que vous avez publié 2) inscription d'aperçu de chaque image avec une pseudo procédure évènementielle qui, si on clique sur l'image, empêche de la sélectionner. 3) compression des images pour éviter d'avoir un classeur Excel de plusieurs Mégas.
CODE A COPIER '******************* '### Constante à adapter ### Const CHEMIN As String = _ "C:ProdEuropaEuropa_2008Web_2008Visuels_finSmall_65x65" '########################### '____________________________ Sub PMO_xxx() '--- Outils/Réferences cocher '--- Microsoft Shell Controls and Automation Dim Nom_Image As String Dim myShell As Shell Dim myFolder As Folder Dim myFile As FolderItem Dim fich As String Dim R As Range Dim PICT As Picture '--- Efface toutes les images exitantes --- For Each PICT In ActiveSheet.Pictures PICT.Delete Next PICT '--- La macro part IMPERATIVEMENT de A1 --- Set R = [a1] Nom_Image = R Set myShell = CreateObject("Shell.Application") Set myFolder = myShell.Namespace(CHEMIN) Do Until Nom_Image = "" fich = Dir(CHEMIN & "" & Nom_Image) If fich <> "" Then R.Hyperlinks.Add R, CHEMIN & "" & Nom_Image Set myFile = myFolder.Items.Item(fich) R.Offset(0, 1) = myFolder.GetDetailsOf(myFile, 26) Call ChargePicture(R, CHEMIN & "" & Nom_Image) Set R = R.Offset(1, -2) Else R.Offset(0, 1) = Nom_Image & " introuvable" Set R = R.Offset(1, 0) End If Nom_Image = R.Value Loop Call CompressionImage '--- Hauteur/ligne, largeur/colonne --- Columns.AutoFit Rows.RowHeight = 32 Columns("C:C").ColumnWidth = 8 [a1].Select Set myFile = Nothing Set myFolder = Nothing Set myShell = Nothing End Sub '____________________________ '### Evite un fichier Excel de plusieurs Méga ### '### l'aperçu de l'image perd en qualité ### Sub CompressionImage(Optional dummy As Byte) Dim C As Object Dim PICT As Picture Dim bool As Boolean For Each PICT In ActiveSheet.Pictures bool = True Exit For Next PICT If Not bool Then Exit Sub Application.ScreenUpdating = False For Each C In _ Application.CommandBars("Picture").Controls If TypeOf C Is CommandBarButton Then If C.ID = 6382 Then Application.SendKeys _ "{DOWN}{TAB}{UP}{ENTER}{ENTER}", True C.Execute Exit For End If End If Next C Application.ScreenUpdating = True End Sub '____________________________ Sub ChargePicture(R As Range, PathMaPhoto As String) Dim PICT As Picture Set R = R.Offset(0, 2) Application.ScreenUpdating = False Set PICT = ActiveSheet.Pictures.Insert(PathMaPhoto) With PICT .Top = R.Top .Left = R.Left .Width = R.Width .Height = R.Height .Placement = xlMoveAndSize '---sansAction : Evite la sélection de l'image --- .OnAction = "sansAction" End With Application.ScreenUpdating = True End Sub '____________________________ Sub sansAction(Optional dummy As Byte) '''vide de traitement, mais nécessaire '''pour éviter la sélection de l'image End Sub '*******************
Cordialement.
PMO Patrick Morange
Bonjour,
Une piste avec le code ci-dessous.
J'ai été obligé de modifier votre sub xxx. Par conséquent et par précaution,
veuillez faire un test sur une COPIE de votre classeur.
La macro part IMPERATIVEMENT de la cellule A1.
Veuillez renseigner le nom de vos photos à partir de A1.
J'ai fait les tests sur Excel 2002.
D'autre part, si vous exécutez le code en mode "Pas à pas détaillé", il
faut faire attention à l'exécution de la sub "CompressionImage" car elle
contient une instruction "Application.SendKeys" qui risque de s'appliquer
dans la fenêtre de code.
CELA FAIT
1) reprise du traitement que vous avez publié
2) inscription d'aperçu de chaque image avec une pseudo procédure
évènementielle qui, si on clique sur l'image, empêche de la sélectionner.
3) compression des images pour éviter d'avoir un classeur Excel de
plusieurs Mégas.
CODE A COPIER
'*******************
'### Constante à adapter ###
Const CHEMIN As String = _
"C:ProdEuropaEuropa_2008Web_2008Visuels_finSmall_65x65"
'###########################
'____________________________
Sub PMO_xxx()
'--- Outils/Réferences cocher
'--- Microsoft Shell Controls and Automation
Dim Nom_Image As String
Dim myShell As Shell
Dim myFolder As Folder
Dim myFile As FolderItem
Dim fich As String
Dim R As Range
Dim PICT As Picture
'--- Efface toutes les images exitantes ---
For Each PICT In ActiveSheet.Pictures
PICT.Delete
Next PICT
'--- La macro part IMPERATIVEMENT de A1 ---
Set R = [a1]
Nom_Image = R
Set myShell = CreateObject("Shell.Application")
Set myFolder = myShell.Namespace(CHEMIN)
Do Until Nom_Image = ""
fich = Dir(CHEMIN & "" & Nom_Image)
If fich <> "" Then
R.Hyperlinks.Add R, CHEMIN & "" & Nom_Image
Set myFile = myFolder.Items.Item(fich)
R.Offset(0, 1) = myFolder.GetDetailsOf(myFile, 26)
Call ChargePicture(R, CHEMIN & "" & Nom_Image)
Set R = R.Offset(1, -2)
Else
R.Offset(0, 1) = Nom_Image & " introuvable"
Set R = R.Offset(1, 0)
End If
Nom_Image = R.Value
Loop
Call CompressionImage
'--- Hauteur/ligne, largeur/colonne ---
Columns.AutoFit
Rows.RowHeight = 32
Columns("C:C").ColumnWidth = 8
[a1].Select
Set myFile = Nothing
Set myFolder = Nothing
Set myShell = Nothing
End Sub
'____________________________
'### Evite un fichier Excel de plusieurs Méga ###
'### l'aperçu de l'image perd en qualité ###
Sub CompressionImage(Optional dummy As Byte)
Dim C As Object
Dim PICT As Picture
Dim bool As Boolean
For Each PICT In ActiveSheet.Pictures
bool = True
Exit For
Next PICT
If Not bool Then Exit Sub
Application.ScreenUpdating = False
For Each C In _
Application.CommandBars("Picture").Controls
If TypeOf C Is CommandBarButton Then
If C.ID = 6382 Then
Application.SendKeys _
"{DOWN}{TAB}{UP}{ENTER}{ENTER}", True
C.Execute
Exit For
End If
End If
Next C
Application.ScreenUpdating = True
End Sub
'____________________________
Sub ChargePicture(R As Range, PathMaPhoto As String)
Dim PICT As Picture
Set R = R.Offset(0, 2)
Application.ScreenUpdating = False
Set PICT = ActiveSheet.Pictures.Insert(PathMaPhoto)
With PICT
.Top = R.Top
.Left = R.Left
.Width = R.Width
.Height = R.Height
.Placement = xlMoveAndSize
'---sansAction : Evite la sélection de l'image ---
.OnAction = "sansAction"
End With
Application.ScreenUpdating = True
End Sub
'____________________________
Sub sansAction(Optional dummy As Byte)
'''vide de traitement, mais nécessaire
'''pour éviter la sélection de l'image
End Sub
'*******************
J'ai été obligé de modifier votre sub xxx. Par conséquent et par précaution, veuillez faire un test sur une COPIE de votre classeur. La macro part IMPERATIVEMENT de la cellule A1. Veuillez renseigner le nom de vos photos à partir de A1. J'ai fait les tests sur Excel 2002.
D'autre part, si vous exécutez le code en mode "Pas à pas détaillé", il faut faire attention à l'exécution de la sub "CompressionImage" car elle contient une instruction "Application.SendKeys" qui risque de s'appliquer dans la fenêtre de code.
CELA FAIT 1) reprise du traitement que vous avez publié 2) inscription d'aperçu de chaque image avec une pseudo procédure évènementielle qui, si on clique sur l'image, empêche de la sélectionner. 3) compression des images pour éviter d'avoir un classeur Excel de plusieurs Mégas.
CODE A COPIER '******************* '### Constante à adapter ### Const CHEMIN As String = _ "C:ProdEuropaEuropa_2008Web_2008Visuels_finSmall_65x65" '########################### '____________________________ Sub PMO_xxx() '--- Outils/Réferences cocher '--- Microsoft Shell Controls and Automation Dim Nom_Image As String Dim myShell As Shell Dim myFolder As Folder Dim myFile As FolderItem Dim fich As String Dim R As Range Dim PICT As Picture '--- Efface toutes les images exitantes --- For Each PICT In ActiveSheet.Pictures PICT.Delete Next PICT '--- La macro part IMPERATIVEMENT de A1 --- Set R = [a1] Nom_Image = R Set myShell = CreateObject("Shell.Application") Set myFolder = myShell.Namespace(CHEMIN) Do Until Nom_Image = "" fich = Dir(CHEMIN & "" & Nom_Image) If fich <> "" Then R.Hyperlinks.Add R, CHEMIN & "" & Nom_Image Set myFile = myFolder.Items.Item(fich) R.Offset(0, 1) = myFolder.GetDetailsOf(myFile, 26) Call ChargePicture(R, CHEMIN & "" & Nom_Image) Set R = R.Offset(1, -2) Else R.Offset(0, 1) = Nom_Image & " introuvable" Set R = R.Offset(1, 0) End If Nom_Image = R.Value Loop Call CompressionImage '--- Hauteur/ligne, largeur/colonne --- Columns.AutoFit Rows.RowHeight = 32 Columns("C:C").ColumnWidth = 8 [a1].Select Set myFile = Nothing Set myFolder = Nothing Set myShell = Nothing End Sub '____________________________ '### Evite un fichier Excel de plusieurs Méga ### '### l'aperçu de l'image perd en qualité ### Sub CompressionImage(Optional dummy As Byte) Dim C As Object Dim PICT As Picture Dim bool As Boolean For Each PICT In ActiveSheet.Pictures bool = True Exit For Next PICT If Not bool Then Exit Sub Application.ScreenUpdating = False For Each C In _ Application.CommandBars("Picture").Controls If TypeOf C Is CommandBarButton Then If C.ID = 6382 Then Application.SendKeys _ "{DOWN}{TAB}{UP}{ENTER}{ENTER}", True C.Execute Exit For End If End If Next C Application.ScreenUpdating = True End Sub '____________________________ Sub ChargePicture(R As Range, PathMaPhoto As String) Dim PICT As Picture Set R = R.Offset(0, 2) Application.ScreenUpdating = False Set PICT = ActiveSheet.Pictures.Insert(PathMaPhoto) With PICT .Top = R.Top .Left = R.Left .Width = R.Width .Height = R.Height .Placement = xlMoveAndSize '---sansAction : Evite la sélection de l'image --- .OnAction = "sansAction" End With Application.ScreenUpdating = True End Sub '____________________________ Sub sansAction(Optional dummy As Byte) '''vide de traitement, mais nécessaire '''pour éviter la sélection de l'image End Sub '*******************