Importation image : nom fichier incomplet
S
Bonjour,
Je suis une nouvelle manipulatrice de Excel VBA et j'ai besoin d'aide !
Je souhaite importer des images d'un fichier qui se trouve sur mon réseau. Pour cela je demande à Excel d'importer l'image à partir du code inscrit dans une cellule. Or ce code est incomplet par rapport au nom du fichier inscrit sur le réseau (exemple : cellule "38210" et fichier jpg "38210_01010"). Je précise que sur le réseau il existe plusieurs fichiers avec le code inscrit dans la cellule (38210_01010 ;38210_01011;38210_01684 ect)
Je souhaite donc demander à Excel qu'il m'affiche la première image qu'il trouve avec le début du nom du fichier.
Mon code de base est celui ci :
Sub Insertion_Image
Dim Ligne As Long, Colonne As Integer
Dim Image As Shape
Dim Chemin As String, Fichier As String
Dim AdImage As String, nom As String
Dim iPict As IPictureDisp 'Récupération des dimensions de l'image
Dim WiPict As Double, HiPict As Double, t As Double, l As Double, w As Double, h As Double
Dim hImgInit As Double, wImgInit As Double, hImgCoef As Double, wImgCoef As Double
Application.ScreenUpdating = False 'Bloque la mise à jour de l'écran
For Each Image In ActiveSheet.Shapes
If Image.Type = msoPicture Then
Debug.Print Image.TopLeftCell.Address, Image.Name
Image.Delete
End If
Next Image
On Error GoTo Erreur 'Gestion des erreurs, renvoir à l'étiquette Erreur
Chemin = Sheets("PARAMETRES").Range("B3").Value 'Définition du nom et du chemin d'acces à l'imagette
For Ligne = 87 To 236 Step 25
For Colonne = 3 To 31 Step 3
nom = Cells(Ligne, Colonne) & ".jpg"
AdImage = Chemin & nom
If Dir(AdImage) <> "" Then
Set iPict = LoadPicture(AdImage)
WiPict = iPict.Width
HiPict = iPict.Height
With Cells(Ligne, Colonne) 'Détermine la position et la dimension de la cellule active
t = .Top
l = .Left
w = .Columns.Width * 3
h = .Rows.Height
End With
Set Image = ActiveSheet.Shapes.AddPicture(AdImage, False, True, l, t, WiPict, HiPict)
With Image
hImgInit = Image.Height 'Détermine la dimension initiale de l'imagette
wImgInit = Image.Width
.Top = t + 2 'Positionne l'imagette dans la cellule active
.Left = l + 2 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize 'Locks the image so it can be sorted (ak)
hImgCoef = hImgInit / h 'Calcul des coefficients de réduction de l'imagette ( hauteur et largeur )
wImgCoef = wImgInit / w
If wImgCoef < hImgCoef Then 'Condition pour choisir le coefficient de réduction le plus grand
.Height = h - 5 'Réduction de l'imagette si le coefficient en hauteur est plus grand
.Width = (wImgInit / hImgCoef) - 5
Else
.Height = (hImgInit / wImgCoef) - 5 'Sinon réduction de l'imagette avec le coefficient en largeur
.Width = w - 5
End If
End With
End If
Next Colonne
Next Ligne
Set iPict = Nothing
Set iPict = Nothing
Application.ScreenUpdating = True 'Réactivation de la mise à jour de l'écran
Exit Sub 'Sortie de la fonction
Erreur: 'Gestion de l'erreur si le chemin n'est pas valide
MsgBox "Pas d'image nommée " & nom & " dans ce répertoire", vbExclamation, Chemin
End SubSub test()
'http://www.excel-downloads.com/forum/25351-ouverture-dun-fichier-avec-un-nom-incomplet.html
Dim nom As String 'déclare la variable nom
dim noncomplet as string 'déclare la variable nomcomplet
Dim chem As String 'déclare la variable chem
nom = InputBox("Nom du classeur") 'définit la variable nom (début du nom du fichier)
chem = ActiveWorkbook.Path 'définit la variable chem (chemin d'accès du classeur actuel, à adapter)
With Application.FileSearch 'recherche de fichier
.LookIn = chem 'dans le même répertoire que le fichier actuel
.SearchSubFolders = True 'dans les sous-répertoires
.Filename = nom & "*.xls" 'tous les fichiers Excel commençant par le nom de la boite
If .Execute > 0 Then 'si au moins un fichier est trouvé
nomcomplet = .FoundFiles(1) 'définit le nom complet du fichier trouvé
Workbooks.Open (nomcomplet) 'ouvre le fichier
End If
End With
End SubJ'ai essayé de faire un petit mix des deux (un peu du deuxième dans le premier!) mais ça ne marche pas !
Merci de votre aide !! J'espère que je suis claire dans ma demande !
Bonjour
Sans fichier test
Modifie la partie correspondante
For Ligne = 87 To 236 Step 25
For Colonne = 3 To 31 Step 3
'nom = Cells(Ligne, Colonne) & ".jpg"
'AdImage = Chemin & nom
'If Dir(AdImage) <> "" Then
nom = Cells(Ligne, Colonne) & "*.jpg"
AdImage = Dir(Chemin & nom)
If AdImage <> "" Then
Set iPict = LoadPicture(AdImage)Attention il faut un \ entre le chemin et le nom du fichier
S
Bonjour,
Merci de votre réponse!
le code devient donc si j'ai bien compris
Sub Insertion_Image
Dim Ligne As Long, Colonne As Integer
Dim Image As Shape
Dim Chemin As String, Fichier As String
Dim AdImage As String, nom As String
Dim iPict As IPictureDisp 'Récupération des dimensions de l'image
Dim WiPict As Double, HiPict As Double, t As Double, l As Double, w As Double, h As Double
Dim hImgInit As Double, wImgInit As Double, hImgCoef As Double, wImgCoef As Double
Application.ScreenUpdating = False 'Bloque la mise à jour de l'écran
For Each Image In ActiveSheet.Shapes
If Image.Type = msoPicture Then
Debug.Print Image.TopLeftCell.Address, Image.Name
Image.Delete
End If
Next Image
On Error GoTo Erreur 'Gestion des erreurs, renvoir à l'étiquette Erreur
Chemin = Sheets("PARAMETRES").Range("B3").Value 'Définition du nom et du chemin d'acces à l'imagette
For Ligne = 87 To 236 Step 25
For Colonne = 3 To 31 Step 3
'nom = Cells(Ligne, Colonne) & ".jpg"
'AdImage = Chemin & nom
'If Dir(AdImage) <> "" Then
nom = Cells(Ligne, Colonne) & "*.jpg"
AdImage = Dir(Chemin & nom)
If AdImage <> "" Then
Set iPict = LoadPicture(AdImage)
Set iPict = LoadPicture(AdImage)
WiPict = iPict.Width
HiPict = iPict.Height
With Cells(Ligne, Colonne) 'Détermine la position et la dimension de la cellule active
t = .Top
l = .Left
w = .Columns.Width * 3
h = .Rows.Height
End With
Set Image = ActiveSheet.Shapes.AddPicture(AdImage, False, True, l, t, WiPict, HiPict)
With Image
hImgInit = Image.Height 'Détermine la dimension initiale de l'imagette
wImgInit = Image.Width
.Top = t + 2 'Positionne l'imagette dans la cellule active
.Left = l + 2 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize 'Locks the image so it can be sorted (ak)
hImgCoef = hImgInit / h 'Calcul des coefficients de réduction de l'imagette ( hauteur et largeur )
wImgCoef = wImgInit / w
If wImgCoef < hImgCoef Then 'Condition pour choisir le coefficient de réduction le plus grand
.Height = h - 5 'Réduction de l'imagette si le coefficient en hauteur est plus grand
.Width = (wImgInit / hImgCoef) - 5
Else
.Height = (hImgInit / wImgCoef) - 5 'Sinon réduction de l'imagette avec le coefficient en largeur
.Width = w - 5
End If
End With
End If
Next Colonne
Next Ligne
Set iPict = Nothing
Set iPict = Nothing
Application.ScreenUpdating = True 'Réactivation de la mise à jour de l'écran
Exit Sub 'Sortie de la fonction
Erreur: 'Gestion de l'erreur si le chemin n'est pas valide
MsgBox "Pas d'image nommée " & nom & " dans ce répertoire", vbExclamation, Chemin
End Subvoici la réponse :
Pas d'image nommée 39772*.jpg dans ce répertoire
Bonjour
Toujours sans support
Voici la macro complète qui fonctionne
Sub Insertion_Image()
Dim Ligne As Long, Colonne As Integer
Dim Image As Shape
Dim Chemin As String, Fichier As String
Dim AdImage As String, nom As String
Dim iPict As IPictureDisp 'Récupération des dimensions de l'image
Dim WiPict As Double, HiPict As Double, t As Double, l As Double, w As Double, h As Double
Dim hImgInit As Double, wImgInit As Double, hImgCoef As Double, wImgCoef As Double
Application.ScreenUpdating = False 'Bloque la mise à jour de l'écran
For Each Image In ActiveSheet.Shapes
If Image.Type = msoPicture Then
Debug.Print Image.TopLeftCell.Address, Image.Name
Image.Delete
End If
Next Image
On Error GoTo Erreur 'Gestion des erreurs, renvoir à l'étiquette Erreur
Chemin = Sheets("PARAMETRES").Range("B3").Value 'Définition du nom et du chemin d'acces à l'imagette
For Ligne = 87 To 236 Step 25
For Colonne = 3 To 31 Step 3
nom = Cells(Ligne, Colonne) & "*.jpg"
AdImage = Dir(Chemin & nom)
If AdImage <> "" Then
Set iPict = LoadPicture(Chemin & AdImage)
WiPict = iPict.Width
HiPict = iPict.Height
With Cells(Ligne, Colonne) 'Détermine la position et la dimension de la cellule active
t = .Top
l = .Left
w = .Columns.Width * 3
h = .Rows.Height
End With
Set Image = ActiveSheet.Shapes.AddPicture(Chemin & AdImage, False, True, l, t, WiPict, HiPict)
With Image
hImgInit = Image.Height 'Détermine la dimension initiale de l'imagette
wImgInit = Image.Width
.Top = t + 2 'Positionne l'imagette dans la cellule active
.Left = l + 2 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize 'Locks the image so it can be sorted (ak)
hImgCoef = hImgInit / h 'Calcul des coefficients de réduction de l'imagette ( hauteur et largeur )
wImgCoef = wImgInit / w
If wImgCoef < hImgCoef Then 'Condition pour choisir le coefficient de réduction le plus grand
.Height = h - 5 'Réduction de l'imagette si le coefficient en hauteur est plus grand
.Width = (wImgInit / hImgCoef) - 5
Else
.Height = (hImgInit / wImgCoef) - 5 'Sinon réduction de l'imagette avec le coefficient en largeur
.Width = w - 5
End If
End With
End If
Next Colonne
Next Ligne
Set iPict = Nothing
Set iPict = Nothing
Application.ScreenUpdating = True 'Réactivation de la mise à jour de l'écran
Exit Sub 'Sortie de la fonction
Erreur: 'Gestion de l'erreur si le chemin n'est pas valide
MsgBox "Pas d'image nommée " & nom & " dans ce répertoire", vbExclamation, Chemin
End SubS
Bonjour,
Pardon je n'avais pas compris !
voici le fichier en PJ
Le code marche ! mais lorsque la cellule (en jaune) est vide, il m'amène la première image du répertoire et j'aimerais qu'il ne me ramène du tout ! comment faire !
D'autre part j'ai une autre question si vous voulez toujours bien m'aider !
le code de base a été créé pour un autre fichier où l'image apparaissait sur la cellule "nom".
Or sur ce fichier j'aimerais que la photo s'affiche sur la case verte au dessus de la case jaune. Est-ce qu'en modifiant les paramètres de taille/position ici
.Top = t + 2 'Positionne l'imagette dans la cellule active
.Left = l + 2 'Positionne l'imagette dans la cellule a gauche (ak)
.Placement = xlMoveAndSize 'Locks the image so it can be sorted (ak)
hImgCoef = hImgInit / h 'Calcul des coefficients de réduction de l'imagette ( hauteur et largeur )
wImgCoef = wImgInit / w
If wImgCoef < hImgCoef Then 'Condition pour choisir le coefficient de réduction le plus grand
.Height = h - 5 'Réduction de l'imagette si le coefficient en hauteur est plus grand
.Width = (wImgInit / hImgCoef) - 5
Else
.Height = (hImgInit / wImgCoef) - 5 'Sinon réduction de l'imagette avec le coefficient en largeur
.Width = w - 5je peux m'en sortir ou l'image sera forcément dans la case jaune ?
S
Bonjour,
ça marche !Merci beaucoup !
Mais j'ai encore un petit problème !
Lorsque je fais marcher la macro, elle efface toutes les photos qui sont déjà présentes ligne 3 et ligne 41 (que je ramène manuellement car elles ne sont pas sur le réseau) !
Bonjour
Modifie cette partie
For Each Image In ActiveSheet.Shapes
If Image.Type = msoPicture Then
If Image.TopLeftCell.Row > 41 Then
Debug.Print Image.TopLeftCell.Address, Image.Name
Image.Delete
End If
End If
Next ImageS
Bonjour,
C'est parfait !!
Merci beaucoup !!