VBA conditions if pour insertion de photos depuis un répertoire
Fermé
didom
-
28 août 2015 à 09:24
cs_Le Pivert
Messages postés7904Date d'inscriptionjeudi 13 septembre 2007StatutContributeurDernière intervention14 août 2024
-
31 août 2015 à 19:48
Bonjour, je plante sur mon dévelloppement de macro VBA pour insertion automatique de photos.
Je reprends depuis le début:
j'ai mis en place une macro afin d'éditer en automatique des fiches de données techniques.
Pour cela, mon fichier comporte 2 onglets, 1 pour la base de données et l'autre pour 1 modèle à remplir.
les données, sous forme de lignes sont remplies si l'on cache la 1ere colonne et que l'on lance la macro. Cette dernière va récupérer les données de la ligne et les insérer dans des cellules particulières du modèle en créant 1 troisième feuille. Tout ceci fonctionne bien.
Je souhaite ensuite insérer une photo également avec cette même macro. Les photos sont nommés avec la même orthographe que les champs de la 3eme colonne qui s'appelle "ID unique".
La macro éditée arrive à insérer les photos mais la ou je plante c'est sur la formule si il ne trouve pas la photo, je souhaite avoir un message m'informant "photo non trouvée, édition fiche impossible" et qu'il supprime le 3eme onglet généré.
s'il trouve la photo, il édite la fiche normalement.
voici ma formaule VBA actuel:
------------------------------------------------------------------------------------
Sub Rapport()
Ouvrir_PDF = MsgBox("Voulez-vous ouvrir les PDF après l'exécution de la macro ?", vbYesNo, "Question")
If Ouvrir_PDF = vbYes Then Ouvrir_PDF = True
If Ouvrir_PDF = vbNo Then Ouvrir_PDF = False
'debut = Timer
Application.ScreenUpdating = False
Dim Nombre_de_rapports_a_imprimer As Integer 'jusqu'à 32 767
Dim Ligne_Max As Integer
Dim Nom_du_workbook As String
Dim Message_de_fin As String
Dim Derniere_ligne As Integer
Dim I As Integer
Dim Groupe_inspecteur As String
Dim ID_unique As String
Dim Chemin_du_workbook As String
'Si aucune croix on ferme
If Derniere_ligne = 1 Then
Message_de_fin = "Aucune croix."
GoTo Label_message_de_fin
End If
'boucle sur toutes les lignes pour détecter le nombre de rapports à imprimerles croix
For I = 9 To Derniere_ligne
If Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 1).Value <> "" Then
'Picture()
Range("H19").Select 'This is where picture will be inserted
Dim picname As String
ActiveSheet.Pictures.Insert("W:\Group\Projet\GA - Méthode arrêts\04-bases de données\01-LG\Photos LG\28LG0109A.jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("I19").Left
.Top = Range("I19").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 190#
.ShapeRange.Width = 152#
.ShapeRange.Rotation = 0#
End With
if ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found Exit Sub Range("B20").Select End Sub
'suppression de l'onglet
Application.DisplayAlerts = False
Workbooks(Nom_du_workbook).Sheets(ID_unique).Delete
Application.DisplayAlerts = True
'suppression de la croix
Sheets("Liste LG").Select
Cells(I, 1).Select
Selection.ClearContents
Cells(I, 42).Select
ActiveCell.FormulaR1C1 = "oui"
Message_de_fin = Message_de_fin & vbNewLine & Workbooks(Nom_du_workbook).Sheets("Liste LG").Cells(I, 2).Value & " - " & ID_unique
Nombre_de_rapports_a_imprimer = Nombre_de_rapports_a_imprimer + 1
End If
Next I
If Nombre_de_rapports_a_imprimer = 1 Then
esse = "."
Else
esse = "s."
End If
tyranausor
Messages postés3545Date d'inscriptionjeudi 6 août 2009StatutMembreDernière intervention 1 avril 20222 033 28 août 2015 à 11:41
Bonjour, une petite question, pour alléger ton code, au lieu de recopier x fois Workbook("Nom_du_workbook").sheets(""Ma_feuille"), pourquoi tu n'utiliserais pas les variables?
pour ton Workbook : Dim Wb as workbook, Ws1 as worksheet, Ws2 as Worksheet
cs_Le Pivert
Messages postés7904Date d'inscriptionjeudi 13 septembre 2007StatutContributeurDernière intervention14 août 2024729 28 août 2015 à 14:13
Bonjour,
Changer ceci:
'Picture()
Range("H19").Select 'This is where picture will be inserted
Dim picname As String
ActiveSheet.Pictures.Insert("W:\Group\Projet\GA - Méthode arrêts\04-bases de données\01-LG\Photos LG\28LG0109A.jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("I19").Left
.Top = Range("I19").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 190#
.ShapeRange.Width = 152#
.ShapeRange.Rotation = 0#
End With
if ErrNoPhoto:
MsgBox "Unable to Find Photo" 'Shows message box if picture not found Exit Sub Range("B20").Select End Sub
par cela:
Range("H19").Select 'This is where picture will be inserted
Dim picname As String
On Error GoTo err
ActiveSheet.Pictures.Insert("W:\Group\Projet\GA - Méthode arrêts\04-bases de données\01-LG\Photos LG\28LG0109A.jpg").Select 'Path to where pictures are stored
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' This resizes the picture
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Selection
.Left = Range("I19").Left
.Top = Range("I19").Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 190#
.ShapeRange.Width = 152#
.ShapeRange.Rotation = 0#
End With
fin:
Exit Sub
err:
'Gestion de l'erreur 76
If err.Number = 76 Then
MsgBox "Ce dossier n'existe pas"
Else
MsgBox "Unable to Find Photo"
End If
Resume fin
Bonjour, le message de photo non trouvé est bien mentionné mais en revanche, lorqsqu'il trouve la photo, la macro s'arrête de se générer après l'insertion sans me terminer les actions qu'il restait ensuite ?
cs_Le Pivert
Messages postés7904Date d'inscriptionjeudi 13 septembre 2007StatutContributeurDernière intervention14 août 2024729
>
didom
31 août 2015 à 19:48
supprime le :
Exit Sub
michel_m
Messages postés16603Date d'inscriptionlundi 12 septembre 2005StatutContributeurDernière intervention16 décembre 20233 306 Modifié par michel_m le 31/08/2015 à 13:19
