XL 2013 un dossier qui ne veut pas etre supprimer avant la fermeture du fichier

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
patricktoulon

patricktoulon

XLDnaute Barbatruc
Bonjour bonjour

aujourd'hui mon pc c'est levé du mauvais processeur le couillon devant mon l'ecran peu être un peu aussi
j'ai deux soucis
1° ma fonction saveallTo pngfile2 ne repond pas comme il devrait
en effet a la fin je supprime des fichiers et dossier temporaire mais là le dossier reste apparent sur le bureau tant que je ferme pas le fichier

le 2d soucis c'est que même avec application.CopyObjectsWithCells= false ca copie les shapes avec quand même

VB: 
Sub Test_une_shape2()
    Dim Chemin$
    Chemin = ThisWorkbook.Path & "\mondossier"
    Set shap = ActiveSheet.Shapes(2)
    SaveAllToPngFile2 shap, Chemin
End Sub

Sub Test_Toutes_Les_Shapes2()
    Dim i&, Chemin$
    Chemin = ThisWorkbook.Path & "\mondossier"
    SaveAllToPngFile2 ActiveSheet.Shapes, Chemin
End Sub
Sub Test_une_Range2()
    Dim Chemin$
    Chemin = ThisWorkbook.Path & "\mondossier"
    Set r = ActiveSheet.Range("A1:f10")
    SaveAllToPngFile2 r, Chemin
End Sub


Sub SaveAllToPngFile2(OBJ, Chemin As String)
    Dim chemintemp, sh, Img$, Nom$
    Application.ScreenUpdating = False

    chemintemp = ThisWorkbook.Path & "\temp.htm"    'chemin temporaire du html

    If TypeName(OBJ) = "Shape" Then OBJ = Array(OBJ)    'si c'est une shape alors OBJ = un array avec juste la shape

    If TypeName(OBJ) = "Range" Then OBJ = Array(OBJ)    'si c'est une range alors OBJ = un array avec juste la range

    'si le dossier n'exite pas on le crée
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir (Chemin)
    Else    'sinon on le vide
        Kill (Chemin & "\*.*")
    End If

    Application.CopyObjectsWithCells = False

    With Workbooks.Add    'ouvre un new classeur provisoire

        For Each sh In OBJ    'boucle sur OBJ
            If TypeName(sh) = "Range" Then
                Nom = Replace(sh.Address(0, 0), ":", "-")
                sh.Copy    'copie de la l'object itéré dans la boucle
            Else
                Nom = Replace(sh.Name, " ", "_") & ".png"
                sh.Copy    'copie de la l'object itéré dans la boucle
            End If

            ActiveSheet.Pictures.Paste    'colle en tant qu'image  dans le new classeur

            'publication en html
            With .PublishObjects.Add(xlSourceSheet, chemintemp, "Feuil1", "", xlHtmlStatic, "calque", "")
                .Publish (True)
                .AutoRepublish = False
            End With

            ActiveSheet.Pictures(1).Delete    'suppression de l'image collée

            'récupération du chemin complet de la premiere image png dans le dossier  affilié au html
            Img = ThisWorkbook.Path & "\temp_fichiers\" & Dir(ThisWorkbook.Path & "\temp_fichiers\" & "*.png")

            Name Img As (Chemin & "\" & Replace(Nom, " ", "_") & ".png")    'transfert dans le dossier désigné
        Next

        .Close False    'fermeture du classeur provisoire
    End With

    Kill chemintemp    'suppression du fichier html

    Kill ThisWorkbook.Path & "\temp_fichiers\*.*"    'vide le dossier affilié au html


    RmDir ThisWorkbook.Path & "\temp_fichiers\"    'supprime le dossier affilié au html

    Application.CutCopyMode = False
End Sub

quelqu'un peut me dire ou je me trompe ?
 
Dernière édition:
Solution
Bernard_XLD
patricktoulon à dit:
re et oui mais je n'ai plus le gridline
Cliquez pour agrandir...
et voila le gridline

1668620450115.png


VB: 
Sub SaveAllToPngFile2(OBJ, Chemin As String)
    Dim cheminHTMLtemp, sh, Img$, Nom$, OBJ2
    Application.ScreenUpdating = False    'Bloque le rafraichissement de l'ecran

    cheminHTMLtemp = ThisWorkbook.Path & "\temp.htm"    'chemin temporaire du html

    If TypeName(OBJ) = "Shape" Then OBJ = Array(OBJ)    'si c'est une shape alors OBJ = un array avec juste la shape

    If TypeName(OBJ) = "Range" Then OBJ = Array(OBJ)    'si c'est une range alors OBJ = un array avec juste la range

    'si le dossier n'exite pas on le crée
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir (Chemin)
    Else    'sinon on le vide
        If Dir(Chemin &...
Trier par date Trier par votes
patricktoulon à dit:
re et oui mais je n'ai plus le gridline
Cliquez pour agrandir...
et voila le gridline

1668620450115.png


VB: 
Sub SaveAllToPngFile2(OBJ, Chemin As String)
    Dim cheminHTMLtemp, sh, Img$, Nom$, OBJ2
    Application.ScreenUpdating = False    'Bloque le rafraichissement de l'ecran

    cheminHTMLtemp = ThisWorkbook.Path & "\temp.htm"    'chemin temporaire du html

    If TypeName(OBJ) = "Shape" Then OBJ = Array(OBJ)    'si c'est une shape alors OBJ = un array avec juste la shape

    If TypeName(OBJ) = "Range" Then OBJ = Array(OBJ)    'si c'est une range alors OBJ = un array avec juste la range

    'si le dossier n'exite pas on le crée
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir (Chemin)
    Else    'sinon on le vide
        If Dir(Chemin & "\*.*") <> "" Then Kill (Chemin & "\*.*")
    End If

    Application.CopyObjectsWithCells = False

    With Workbooks.Add    'ouvre un new classeur provisoire

        For Each sh In OBJ    'boucle sur OBJ
            If TypeName(sh) = "Range" Then
                Nom = Replace(sh.Address(0, 0), ":", "-")
                For Each OBJ2 In sh.Parent.Shapes
                    If Not Intersect(OBJ2.TopLeftCell, OBJ(0)) Is Nothing Then OBJ2.Visible = False
                Next OBJ2
                sh.Copy    'copie de la l'object itéré dans la boucle
                ActiveSheet.Pictures.Paste.Select    'colle en tant qu'image  dans le new classeur
                With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.ObjectThemeColor = msoThemeColorBackground1
                    .ForeColor.TintAndShade = 0
                    .ForeColor.Brightness = 0
                    .Solid
                End With
                For Each OBJ2 In sh.Parent.Shapes
                    If Not Intersect(OBJ2.TopLeftCell, OBJ(0)) Is Nothing Then OBJ2.Visible = True
                Next OBJ2
            Else
                Nom = Replace(sh.Name, " ", "_") & ".png"
                sh.Copy    'copie de la l'object itéré dans la boucle
                With ActiveSheet
                    .Pictures.Paste    'colle en tant qu'image  dans le new classeur
                    .Shapes(.Shapes.Count).Select
                    With .Shapes(.Shapes.Count).ShapeRange.Fill
                        .Visible = msoTrue
                        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
                        .ForeColor.TintAndShade = 0
                        .ForeColor.Brightness = 0
                        .Transparency = 0
                        .Solid
                    End With
                End With
            End If

            'publication en html
            With .PublishObjects.Add(xlSourceSheet, cheminHTMLtemp, "Feuil1", "", xlHtmlStatic, "calque", "")
                .Publish (True)
                .AutoRepublish = False
            End With

            ActiveSheet.Pictures(1).Delete    'suppression de l'image collée

            'récupération du chemin complet de la premiere image png dans le dossier  affilié au html
            Img = ThisWorkbook.Path & "\temp_fichiers\" & Dir(ThisWorkbook.Path & "\temp_fichiers\" & "*.png")

            Name Img As (Chemin & "\" & Replace(Nom, " ", "_") & ".png")    'transfert dans le dossier désigné
        Next

        .Close False    'fermeture du classeur provisoire
    End With

    Kill cheminHTMLtemp    'suppression du fichier html
    If Dir(ThisWorkbook.Path & "\temp_fichiers\*.*") <> "" Then Kill ThisWorkbook.Path & "\temp_fichiers\*.*"    'vide le dossier affilié au html
    RmDir ThisWorkbook.Path & "\temp_fichiers"    'supprime le dossier affilié au html

    Application.CutCopyMode = False
End Sub
 
Vote positif 0 Vote négatif
Solution
re
il te faut pas le faire dans le else sinon les shapes perdent leur transparence
le fond blanc c'est que pour le "Range"

code final adopté

VB: 
Option Explicit

Sub Test_une_shape2()
    Dim Chemin$, shap
    Chemin = ThisWorkbook.Path & "\mondossier"
    Set shap = ActiveSheet.Shapes(2)
    SaveAllToPngFile2 shap, Chemin
End Sub

Sub Test_Toutes_Les_Shapes2()
    Dim i&, Chemin$
    Chemin = ThisWorkbook.Path & "\mondossier"
    SaveAllToPngFile2 ActiveSheet.Shapes, Chemin
End Sub

Sub Test_une_Range2()
    Dim Chemin$, r As Variant
    Chemin = ThisWorkbook.Path & "\mondossier"
    Set r = ActiveSheet.Range("A1:f10")
    SaveAllToPngFile2 r, Chemin
End Sub




Sub SaveAllToPngFile2(OBJ, Chemin As String)
    Dim cheminHTMLtemp, sh, Img$, Nom$, OBJ2
    Application.ScreenUpdating = False    'Bloque le rafraichissement de l'ecran

    cheminHTMLtemp = ThisWorkbook.Path & "\temp.htm"    'chemin temporaire du html

    If TypeName(OBJ) = "Shape" Then OBJ = Array(OBJ)    'si c'est une shape alors OBJ = un array avec juste la shape

    If TypeName(OBJ) = "Range" Then OBJ = Array(OBJ)    'si c'est une range alors OBJ = un array avec juste la range

    'si le dossier n'exite pas on le crée
    If Dir(Chemin, vbDirectory) = "" Then
        MkDir (Chemin)
    Else    'sinon on le vide
        If Dir(Chemin & "\*.*") <> "" Then Kill (Chemin & "\*.*")
    End If

    Application.CopyObjectsWithCells = False

    With Workbooks.Add    'ouvre un new classeur provisoire
        For Each sh In OBJ    'boucle sur OBJ
            If TypeName(sh) = "Range" Then
                Nom = Replace(sh.Address(0, 0), ":", "-")
                For Each OBJ2 In sh.Parent.Shapes
                    If Not Intersect(OBJ2.TopLeftCell, OBJ(0)) Is Nothing Then OBJ2.Visible = False
                Next OBJ2
                sh.Copy    'copie de la l'object itéré dans la boucle
                ActiveSheet.Pictures.Paste.Select    'colle en tant qu'image  dans le new classeur
                With Selection.ShapeRange.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = vbWhite
                    .Transparency = 0
                    .Solid
                End With
                For Each OBJ2 In sh.Parent.Shapes
                    If Not Intersect(OBJ2.TopLeftCell, OBJ(0)) Is Nothing Then OBJ2.Visible = True
                Next OBJ2
            Else
                Nom = Replace(sh.Name, " ", "_") & ".png"
                sh.Copy    'copie de  l'object itéré dans la boucle
                ActiveSheet.Pictures.Paste    'colle en tant qu'image  dans le new classeur
            End If

            'publication en html
            With .PublishObjects.Add(xlSourceSheet, cheminHTMLtemp, "Feuil1", "", xlHtmlStatic, "calque", "")
                .Publish (True)
                .AutoRepublish = False
            End With

            ActiveSheet.Pictures(1).Delete    'suppression de l'image collée

            'récupération du chemin complet de la premiere image png dans le dossier  affilié au html
            Img = ThisWorkbook.Path & "\temp_fichiers\" & Dir(ThisWorkbook.Path & "\temp_fichiers\" & "*.png")

            Name Img As (Chemin & "\" & Replace(Nom, " ", "_") & ".png")    'transfert dans le dossier désigné
        Next

        .Close False    'fermeture du classeur provisoire
    End With

    Kill cheminHTMLtemp    'suppression du fichier html
    If Dir(ThisWorkbook.Path & "\temp_fichiers\*.*") <> "" Then Kill ThisWorkbook.Path & "\temp_fichiers\*.*"    'vide le dossier affilié au html
    RmDir ThisWorkbook.Path & "\temp_fichiers"    'supprime le dossier affilié au html

    Application.CutCopyMode = False
End Sub
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

patricktoulon
zip And unzip des éléments d'un fichier de type zip y compris les fichiers Excelavec la commande (TAR)
Réponses
2
Affichages
430
patricktoulon
patricktoulon
P
  • Résolu(e)
XL 2019 chemin universel pour supprimer un fichier sur le bureau de n'importe quel PC
Réponses
3
Affichages
1 K
pat66
P
P
  • Question Question
XL 2019 Macro qui ralenti mon classeur après exécution
Réponses
2
Affichages
827
pat66
P
patricktoulon
  • Résolu(e)
Autres générer un nom de fichier image qui n'existe pas dans le dossier
Réponses
7
Affichages
753
patricktoulon
patricktoulon
Anthonymctm
  • Question Question
XL 2016 Cadrage et propriété d'images issues d'une macro
Réponses
6
Affichages
1 K
Anthonymctm
Anthonymctm
bellenm
  • Question Question
Gmail via CDO, attacher un fichier PDF, des adresses, un objet et un corps bien définit, code de Roland_M.
2 3
Réponses
43
Affichages
6 K
Roland_M
Roland_M
F
  • Question Question
Ouvrir un fichier pdf impossible car la variable ne prend pas la valeur de l'adresse
2 3
Réponses
35
Affichages
5 K
Fariri
F
S
  • Question Question
[résolue]un souci dans une macro qui marchait avant
Réponses
5
Affichages
1 K
stephsteph
S
R
  • Question Question
Macro - ajouter du code pour automatiser la réponse à une fenêtre de message!
Réponses
1
Affichages
1 K
Paf
Paf
G
  • Question Question
Insertion d'image en fonction du résultat d'une celulle ( +20 000 résultats possible)
Réponses
3
Affichages
1 K
Lone-wolf
Lone-wolf
B
  • Question Question
un composant activex ne peut pas créer d'objet vba
Réponses
2
Affichages
5 K
brizard
B
pascal21
  • Question Question
MACRO pour creation de pdf qui ne fonctionne pas sur pc portable
Réponses
6
Affichages
2 K
pascal21
pascal21
M
  • Question Question
Vérifier l'existance d'un dossier avant de générer un fichier
Réponses
1
Affichages
730
Pierrot93
Pierrot93
J
  • Question Question
Appliquer fonction VBA sur une seule feuille
Réponses
2
Affichages
2 K
Jeremouse1
J
S
  • Question Question
Ouvrir un fichier seulement si le nom ne dépasse pas un certain nombre de caratères
Réponses
5
Affichages
2 K
SERIEUXETCOOL
S
S
  • Question Question
Provoquer une erreur après l'ouverture d'un fichier si la condition pas respectée
Réponses
12
Affichages
1 K
shenmicke
S
M
[REF] Wiki Page 8 de MichelXld
Réponses
0
Affichages
39 K
MichelXld
M
M
[REF] Wiki 1 de MichelXld (Généralités Excel)
Réponses
6
Affichages
60 K
Le_Phénomène
Le_Phénomène
M
[REF] Wiki 2 de MichelXld (Ce qui touche aux UserForm)
Réponses
0
Affichages
116 K
MichelXld
M
M
[REF] Wiki 3 de MichelXld (Piloter d'autres applications depuis Excel)
Réponses
0
Affichages
81 K
MichelXld
M
Retour