macro vignette image

Le
catochem
Bonjour,

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:ProdWeb_2008Visuels_finSmall_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

A trés vite
Catochem
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
PMO
Le #5424651
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
Publicité
Poster une réponse
Anonyme