IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

macro insertions images et redimensionnement [XL-2003]


Sujet :

Macros et VBA Excel

  1. #1
    Futur Membre du Club
    Profil pro
    Inscrit en
    Septembre 2007
    Messages
    6
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Septembre 2007
    Messages : 6
    Points : 5
    Points
    5
    Par défaut macro insertions images et redimensionnement
    Bonjour à tous !
    Voici ce que je voudrais faire : Je dois générer des "fiches d'identité" de différents éléments de réseaux d'eau usée et potable. La fiche type est déjà prête.
    Pour le moment, mon fichier excel comporte deux feuilles : "base de données" et "EU (1)"
    la "base de données" contient tous les renseignements relatif à chaque élément du réseau, y compris une case pour le suffixe de la photo, et son numéro (exemple : suffixe DSCF et numéro de photo 003). Pour le moment, j'ai crée un spinbouton qui permet de remplir toute la fiche EU (1) à partir des éléments de base de donnée, en fonction du numéro de l'élément (simple copie de case à case).
    Maintenant, ce que je voudrais faire, c'est aller chercher la photo correspondant à l'élément du réseau, l'insérer au bon endroit dans la fiche EU, et redimensionner la photo de façon à ce qu'elle rentre dans l'espace prévu, quelle que soit sa taille ou son orientation, en conservant ses proportions d'origine. Pour le moment, j'ai bricolé ça :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    Private Sub SpinButton1_Change()
    Dim Image As Variant 'variable "nom du fichier"
    Dim sh As Shape ' variable pour image à effacer
    Dim L, T, W, H As Single 'futures dimensions de l'image
    Dim R, C, P As String ' variables "numéro de photo"
    
    ActiveSheet.[A20].Select 'sélection de la cellule cible dans EU (1)
    
    'sélection de la cellule cible
    L = 15  ' ActiveCell.Left
    T = ActiveCell.Top
    W = 210
    H = 210
    
    For Each sh In ActiveSheet.Shapes ' Boucle d'effacement de l'image précédente
        If Not Intersect(Range(sh.TopLeftCell.Address), Range("A20:D33")) Is Nothing Or _
            Not Intersect(Range(sh.BottomRightCell.Address), Range("A20:D33")) Is Nothing Then
            sh.Delete
        End If
    Next sh
    
    R = ActiveSheet.[H6].Value * 8 - 5 'prend le numéro de l'élément défini par le spinbouton et ajoute 8 lignes correspondantes aux informations de chaque élément sur la feuille "base de données"
    P = Sheets("Base de données").Cells(R, 14).Value 'numéro de la photo dans la feuille base de données
    Set suffixe = Sheets("Base de données").Cells(R, 13).Value 'là, j'ai un problème...
        If Sheets("Base de données").Cells(R, 14).Value = "" Then 'si pas de photo
           ' il faudrait sortir de la macro...    
            Else
            Image = Application.ActiveWorkbook.Path + "\photos\" + suffixe + P + ".JPG" 'select° photo
                   
                If Image <> False Then 'si taille photo différente de cellule
                    ActiveSheet.Shapes.AddPicture Image, True, True, L, T, W, H 'redimensionne
                End If
       
        End If
    'Insertion du radiant
    Sheets("Base de données").Select
    ActiveSheet.Shapes("Groupe 2").Select
    Selection.Copy
    Sheets("EU (1)").Select
    Range("A20 : D33").Select
    ActiveSheet.Paste
    Selection.ShapeRange.IncrementLeft 15
    Selection.ShapeRange.IncrementTop 9.75
    
    'générer la fiche dans une nouvelle feuille et passer à la suivante
    Sheets("EU (1)").Select
    Sheets("EU (1)").Copy After:=Sheets(2)
    'il manque une boucle pour passer à l'élément n°2
    End Sub
    Donc mon gros problème, c'est que les suffixes DSCF etc... ne sont pas toujours les même et le nombre d'élément est parfois trop important pour renommer une à une les photos. Je voudrais que la macro trouve la photo à partir du suffixe défini dans la case R,13 de "base de données", de son numéro en R,14, ensuite qu'elle l'insère dans EU, garde les proportions et la redimensionne (sachant que dans mon code, je fixe les dimensions au départ, et ça déforme la photo; ce n'est pas ce que je voudrais).
    Ensuite, il faudrait que la fiche ainsi crée soit copier en une nouvelle feuille en dernier, et on passe à l'élément 2, et ainsi de suite jusqu'à ce qu'il n'y ait plus de numéro d'élément.
    pouvez-vous m'aider à réparer/modifier cette macro ? Je vous en remercie beaucoup par avance.
    Cordialement

    PS : je l'ai créer sous Excel 2003 car :
    c'est celui que j'ai chez moi !
    Plus facile d'accéder au VBA et aux macros (en tout cas pour moi)
    Par contre, au boulot, c'est Office 2007 (pb de compatibilité ?).
    Images attachées Images attachées  

  2. #2
    Expert éminent sénior Avatar de mercatog
    Homme Profil pro
    Inscrit en
    Juillet 2008
    Messages
    9 435
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations forums :
    Inscription : Juillet 2008
    Messages : 9 435
    Points : 31 877
    Points
    31 877
    Par défaut
    Bonjour
    Utilise plutôt un contrôle activeX Image sur ta feuille EU(1) (Qui prend en charge le zoom sans distortion) et adapte ce code sur le spinbutton
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    Private Sub SpinButton1_Change()
    Dim Chemin As String, FichierImage As String, Suffixe As String, P As String
    Dim R As Integer
     
    Application.ScreenUpdating = False
    With Sheets("EU (1)")
        R = .Range("H6").Value * 8 - 5
        If R > 0 Then
            .Image1.Picture = LoadPicture("")
            P = Sheets("Base de données").Cells(R, 14).Value
            Suffixe = Sheets("Base de données").Cells(R, 13).Value
            If P <> "" Then
                On Error Resume Next
                Application.DisplayAlerts = False
                Sheets(Suffixe & P).Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                Chemin = ThisWorkbook.Path & "\photos\"
                FichierImage = Suffixe & P & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
                    .Copy After:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = Suffixe & P
                    .Activate
                End If
            End If
        End If
    End With
    End Sub
    Cordialement.
    J'utilise toujours le point comme séparateur décimal dans mes tests.

  3. #3
    Futur Membre du Club
    Profil pro
    Inscrit en
    Septembre 2007
    Messages
    6
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Septembre 2007
    Messages : 6
    Points : 5
    Points
    5
    Par défaut
    Merci beaucoup pour la rapidité de la réponse.

    Par rapport à la solution proposé, j'ai copié le code, mais il bug au niveau de cette ligne :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
     
    .Image1.Picture = LoadPicture("")
    Il me dit "propriété ou méthode non géré par cet objet". Est-ce que ça vient du fait que Image1 n'existe pas dans la page (vu le nombre d'essai que j'ai fait, la prochaine image inséré sera peut-être la 250e !)
    Question : une donnée définie comme string peut-elle stoker du texte (en l'occurrence, le suffixe)?

    Par ailleurs, j'avoue ne connaître l'activeX que de nom uniquement (je n'ai aucune idée de ce que c'est ou de son fonctionnement).

    Comment faire ?

    Cordialement.

    voici le code que j'ai ré-adapté :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
     
    Private Sub SpinButton1_Change()
    Dim Image As Variant 'variable "nom du fichier"
    Dim sh As Shape ' variable pour image à effacer
    Dim L, T, W, H As Single 'futures dimensions de l'image
    ' variables "numéro de photo"
    Dim Chemin As String, FichierImage As String, Suffixe As String, P As String
    Dim R As Integer
     
    ActiveSheet.[A20].Select 'sélection de la cellule cible dans EU (1)
     
    'sélection de la cellule cible
    'L = 15 ' ActiveCell.Left
    'T = ActiveCell.Top
    'W = 210
    'H = 210
     
    For Each sh In ActiveSheet.Shapes ' Boucle d'effacement de l'image précédente
    If Not Intersect(Range(sh.TopLeftCell.Address), Range("A20 : D33")) Is Nothing Or _
    Not Intersect(Range(sh.BottomRightCell.Address), Range("A20 : D33")) Is Nothing Then
    sh.Delete
    End If
    Next sh
     
     
    Application.ScreenUpdating = False
    With Sheets("EU (1)")
        R = .Range("H6").Value * 8 - 5
        If R > 0 Then
            .Image1.Picture = LoadPicture("")
            P = Sheets("Base de données").Cells(R, 14).Value
            Suffixe = Sheets("Base de données").Cells(R, 13).Value
            If P <> "" Then
                On Error Resume Next
    '            Application.DisplayAlerts = False
    '            Sheets(Suffixe & P).Delete
    '            Application.DisplayAlerts = True
    '            On Error GoTo 0
                Chemin = ThisWorkbook.Path & "\photos\"
                FichierImage = Suffixe & P & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
                    .Copy After:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = Suffixe & P
                    .Activate
                End If
            End If
        End If
    End With
     
     
    'R = ActiveSheet.[H6].Value * 8 - 5 'prend le numéro de l'élément défini par le spinbouton et ajoute 8 lignes correspondantes aux informations de chaque élément sur la feuille "base de données"
    'P = Sheets("Base de données").Cells(R, 14).Value 'numéro de la photo dans la feuille base de données
    'Set Suffixe = Sheets("Base de données").Cells(R, 13).Value 'là, j'ai un problème...
    'If Sheets("Base de données").Cells(R, 14).Value = "" Then 'si pas de photo
    ' il faudrait sortir de la macro...
    'Else
    'Image = Application.ActiveWorkbook.Path + "\photos\" + Suffixe + P + ".JPG" 'select° photo
     
    'If Image <> False Then 'si taille photo différente de cellule
    'ActiveSheet.Shapes.AddPicture Image, True, True, L, T, W, H 'redimensionne
    'End If
     
    'End If
    'Insertion du radiant
    Sheets("Base de données").Select
    ActiveSheet.Shapes("Groupe 2").Select
    Selection.Copy
    Sheets("EU (1)").Select
    Range("A20 : D33").Select
    ActiveSheet.Paste
    Selection.ShapeRange.IncrementLeft 15
    Selection.ShapeRange.IncrementTop 9.75
     
    'générer la fiche dans une nouvelle feuille et passer à la suivante
    Sheets("EU (1)").Select
    Sheets("EU (1)").Copy After:=Sheets(2)
    'il manque une boucle pour passer à l'élément n°2
    End Sub
    Sauf qu'il bug sur le :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    .Image1.Picture = LoadPicture("")
    Merci de votre aide.

  4. #4
    Expert éminent sénior Avatar de mercatog
    Homme Profil pro
    Inscrit en
    Juillet 2008
    Messages
    9 435
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations forums :
    Inscription : Juillet 2008
    Messages : 9 435
    Points : 31 877
    Points
    31 877
    Par défaut
    Non, peut être je n'étais pas assez clair
    Sur ta feuille EU (1), tu insère un contrôle ActiveX Image (c'est comme l'insertion de ta spinbutton)
    Ce contrôle est nommé Image1
    Tu le place manuellement là où tu veux sur ta feuille EU (1)
    Tu peux même régler les propriétés BackStyle et BorderStyle à transparent

    Le code fourni permet de remplir Image1 par l'image choisie par son suffixe et n°

    C-joint, code amélioré (sur Change de ta spinbutton)
    J'ai considéré que le nom du fichier image et de type SuffixeNum.jpg (avec Suffixe: texte et Num nombre à 3 chiffre 001, 002...999)
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    Private Sub SpinButton1_Change()
    Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String
    Dim Lig As Integer
     
    Application.ScreenUpdating = False
    With Sheets("EU (1)")
        Lig = .Range("H6").Value * 8 - 5
        If Lig > 0 Then
            .Image1.Picture = LoadPicture("")
            With Sheets("Base de données")
                SufImg = .Range("M" & Lig).Value
                NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
            End With
            If NumImg <> "" Then
                On Error Resume Next
                Application.DisplayAlerts = False
                Sheets(SufImg & NumImg).Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                Chemin = ThisWorkbook.Path & "\photos\"
                FichierImage = SufImg & NumImg & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
                    .Copy After:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = SufImg & NumImg
                    Sheets(SufImg & NumImg).Shapes("SpinButton1").Delete
                    .Activate
                End If
            End If
        End If
    End With
    End Sub

    Edit: String = Chaine de caractères, c'est à dire texte
    Cordialement.
    J'utilise toujours le point comme séparateur décimal dans mes tests.

  5. #5
    Futur Membre du Club
    Profil pro
    Inscrit en
    Septembre 2007
    Messages
    6
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Septembre 2007
    Messages : 6
    Points : 5
    Points
    5
    Par défaut Ca marche !!
    Merci beaucoup pour toutes ces précisions ! Je n'avais pas compris ce qu'était un activeX. Je l'ai intégré, j'ai fait des modifications mineurs et ça fonctionne parfaitement !
    Un grand merci pour ton aide !!
    voici le code :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    Private Sub CommandButton1_Click()
    Dim Image As Variant 'variable "nom du fichier"
    Dim sh As Shape ' variable pour image à effacer
     
    ' variables "numéro de photo"
    Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String, P As String, NSheets As String
    'NSheets pour le nom de la nouvelle feuille générée à la fin
     
    Dim Lig As Integer
    Dim R As Integer, compteur As Integer
     
    compteur = 1 ' afin de générer en boucle toutes les fiches
    Sheets("EU (1)").Select
    For compteur = 1 To 10 'à modifier plus tard pour définir le nombre de fiches à générer
     
    Sheets("EU (1)").Select
    ActiveSheet.[H6].Value = compteur
     
    Application.ScreenUpdating = False
    With Sheets("EU (1)")
        Lig = .Range("H6").Value * 8 - 5 ' 8 lignes d'informations et 3 lignes de titres au début d'où : numéro de fiche x 8 -5
        If Lig > 0 Then
            .Image1.Picture = LoadPicture("")
            With Sheets("Base de données")
                SufImg = .Range("M" & Lig).Value
                NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
            End With
            If NumImg <> "" Then
                On Error Resume Next
                Application.DisplayAlerts = False
                Sheets(SufImg & NumImg).Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                Chemin = ThisWorkbook.Path & "\photos\"
                FichierImage = SufImg & NumImg & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
                    .Copy After:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = "EU " & compteur 'on renomme la nouvelle fiche en "EU 2" ou 3 etc... au fur et à mesure du compteur
                    Sheets("EU " & compteur).Shapes("CommandButton1").Delete ' pour faire plus joli !!
                    .Activate
                End If
            End If
        End If
    End With
     
    Next
     
    End Sub
    Ca fonctionne pour n'importe quel suffixe. Pour les numéros de photo, je n'ai pas vérifié au dessus de 009, mais je suppose que ça marche.
    Maintenant, je vais plancher sur le fait d'avoir à ne modifier qu'une seule fiche, on en implémenter d'autres à partir de la dernière.
    Merci encore de votre aide

    Cordialement

  6. #6
    Expert éminent sénior Avatar de mercatog
    Homme Profil pro
    Inscrit en
    Juillet 2008
    Messages
    9 435
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations forums :
    Inscription : Juillet 2008
    Messages : 9 435
    Points : 31 877
    Points
    31 877
    Par défaut
    Les Select à éviter
    Tu as oublier de supprimer par exemple la feuille EU 2 avant de créer une nouvelle.

    Code modifié
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    Private Sub CommandButton1_Click()
    Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String
    Dim LastLig As Integer, Lig As Integer, Compteur As Integer
     
    Application.ScreenUpdating = False
    Chemin = ThisWorkbook.Path & "\photos\"
    With Sheets("Base de données")
        LastLig = .Cells(.Rows.Count, "M").End(xlUp).Row
    End With
    With Sheets("EU (1)")
        For Lig = 3 To LastLig Step 8
            Compteur = Compteur + 1
            .Image1.Picture = LoadPicture("")
            With Sheets("Base de données")
                SufImg = .Range("M" & Lig).Value
                NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
            End With
            If NumImg <> "" Then
                Application.DisplayAlerts = False
                On Error Resume Next
                Sheets("EU " & Compteur).Delete
                On Error GoTo 0
                Application.DisplayAlerts = True
                FichierImage = SufImg & NumImg & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
                    .Copy After:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = "EU " & Compteur    'on renomme la nouvelle fiche en "EU 2" ou 3 etc... au fur et à mesure du compteur
                    Sheets("EU " & Compteur).Shapes("CommandButton1").Delete    ' pour faire plus joli !!
                    .Activate
                End If
            End If
        Next Lig
    End With
    End Sub
    Cordialement.
    J'utilise toujours le point comme séparateur décimal dans mes tests.

  7. #7
    Futur Membre du Club
    Profil pro
    Inscrit en
    Septembre 2007
    Messages
    6
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : Septembre 2007
    Messages : 6
    Points : 5
    Points
    5
    Par défaut Compléments
    Bonsoir,

    Et bien en fait, le but est de générer les fiches les unes après les autres, et de les conserver. Donc en l'état, ça a l'air de fonctionner. Par contre, j'ai rajouté quelques fonctions :

    macro principale :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    Private Sub CommandButton1_Click()
    Dim Image As Variant 'variable "nom du fichier"
    Dim sh As Shape ' variable pour image à effacer
    ' variables "numéro de photo"
    Dim Chemin As String, FichierImage As String, SufImg As String, NumImg As String, P As String, NSheets As String
    Dim Lig As Integer, R As Integer, compteur As Integer
     
    compteur = 1
    Sheets("EU (1)").Select
     
    For compteur = 1 To 480
     
    Sheets("EU (1)").Select
    ActiveSheet.[H6].Value = compteur 'sélection de la cellule cible dans EU (1)
     
    Application.ScreenUpdating = False
    With Sheets("EU (1)")
        Lig = .Range("H6").Value * 8 - 5
        If Lig > 0 Then
            .Image1.Picture = LoadPicture("")
            With Sheets("Base de données")
                SufImg = .Range("M" & Lig).Value
                NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
            End With
            If NumImg <> "" Then
                On Error Resume Next
                Application.DisplayAlerts = False
                Sheets(SufImg & NumImg).Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                Chemin = ThisWorkbook.Path & "\photos\"
                FichierImage = SufImg & NumImg & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
                    .Copy After:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = "EU " & compteur
                    Sheets("EU " & compteur).Shapes("CommandButton1").Delete
                    Sheets("EU " & compteur).Shapes("CommandButton2").Delete
                    Sheets("EU " & compteur).Shapes("CommandButton3").Delete
                    Sheets("EU " & compteur).Shapes("CommandButton4").Delete
                    .Activate
                End If
            End If
        End If
    End With
     
    Next
     
    End Sub
    Les commandbutton 2 à 4 sont des bouton supplémentaires :

    code commandbuton2 : il ouvre une fenêtre pour ne modifier que l'image d'une fiche précise, renseignée dans deux boites de texte (feuille et n° de photo) d'une userform
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    Private Sub CommandButton3_Click()
     
    Dim no As String
    Dim nom As String
    no = UserForm2.fichebox.Value
    nom = UserForm2.photobox.Value
     
    Sheets("EU " & no).Select
     
    Dim Chemin As String, FichierImage As String
    'Dim SufImg As String, NumImg As String
    Dim Lig As Integer
     
    Application.ScreenUpdating = False
    With Sheets("EU " & no)
    '    Lig = .Range("H6").Value * 8 - 5
    '    If Lig > 0 Then
            .Image1.Picture = LoadPicture("")
    '        With Sheets("Base de données")
    '            SufImg = .Range("M" & Lig).Value
    '            NumImg = CStr(Format(.Range("N" & Lig).Value, "000"))
    '        End With
    '        If NumImg <> "" Then
    '            On Error Resume Next
                Application.DisplayAlerts = False
    '            Sheets(SufImg & NumImg).Delete
                Application.DisplayAlerts = True
                On Error GoTo 0
                Chemin = ThisWorkbook.Path & "\photos\"
                FichierImage = nom & ".JPG"
                If Dir(Chemin & FichierImage) <> "" Then
                    .Image1.Picture = LoadPicture(Chemin & FichierImage)
                    .Image1.PictureSizeMode = 3
    '                .Copy After:=Worksheets(Worksheets.Count)
    '                Worksheets(Worksheets.Count).Name = SufImg & NumImg
    '                Sheets(SufImg & NumImg).Shapes("SpinButton1").Delete
                    .Activate
                End If
    '        End If
    '    End If
    End With
    UserForm2.Hide
     
    End Sub
    En fait, j'ai repris le code de tout à l'heure et j'ai désactivé les lignes qui ne servait pas (à priori...)

    et enfin le troisième bouton :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    Private Sub CommandButton3_Click()
    Dim ShtErase As Integer
    For ShtErase = 1 To 480
    On Error Resume Next
    Sheets("EU " & ShtErase).Delete
    Next
    End Sub
    pour effacer toutes les fiches générées, au cas où.

    Le 4e bouton n'ouvre qu'une fenêtre avec quelques explications.
    A ce point là, tout fonctionne très bien. Sauf...
    Quand je génère, modifie, supprime génère,supprime, etc... Au bout de 2 ou trois fois, un bug apparaît dans la dénomination de la nouvelle feuille. Je ne sais pas pourquoi. Dans le même temps, ces fonctions supplémentaires ne sont là qu'en cas de modification exceptionnelle.

    Je sauvegarde, Excel 2003, ça fonctionne très bien. Mais mon collègue me dit qu'en ouvrant le fichier .xls avec Excel 2007, il y a un mini bug :
    Normalement, devant la zone d'insertion de la photo, il doit y avoir un radiant (un cercle avec l'orientation pour se repérer). Tant que je l'ouvre en 2003, pas de problème, les fiches sont générées avec ce fichier .png par dessus la zone d'insertion d'image. Mais en 2007, il semble que ce radiant soit en dessous de la zone d'insertion : comment le mettre et le maintenir au dessus ?

    Je te remercie de ton aide.
    Cordialement.

  8. #8
    Expert éminent sénior Avatar de mercatog
    Homme Profil pro
    Inscrit en
    Juillet 2008
    Messages
    9 435
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations forums :
    Inscription : Juillet 2008
    Messages : 9 435
    Points : 31 877
    Points
    31 877
    Par défaut
    Bonjour,
    Sans tester mon dernier code et sans adapter le tien en conséquence, je pense qu'au lieu d'avancer, tu vas tourner en rond.
    Au moins, il fallait reporter les résultats de ton éventuel test
    PS: Mon dernier code proposé ci-haut était ton code modifié en sorte de prévenir certains bug (notamment éviter de nommer une feuille d'un nom déjà existant et éviter l'instabilité due aux Select).
    à toi de voir comment continuer
    Cordialement.
    J'utilise toujours le point comme séparateur décimal dans mes tests.

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. [OpenOffice][Texte] [Macro] Insertion image - Ooo 3.3
    Par djibril dans le forum OpenOffice & LibreOffice
    Réponses: 1
    Dernier message: 22/06/2011, 09h57
  2. [PPT-2010] Macro Insertion Image depuis Excel
    Par fidecourt dans le forum VBA PowerPoint
    Réponses: 4
    Dernier message: 18/01/2011, 18h08
  3. insertion image avec macro sans doublon lors de la réexécution
    Par picogunsy dans le forum Macros et VBA Excel
    Réponses: 7
    Dernier message: 08/07/2010, 15h24
  4. insertion image avec une macro pour word
    Par bricoleur76 dans le forum VBA Word
    Réponses: 3
    Dernier message: 12/03/2009, 22h14
  5. [VBA-E] Macro Insertion image
    Par dafalri dans le forum Macros et VBA Excel
    Réponses: 3
    Dernier message: 24/05/2006, 17h20

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo