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

patricktoulon · 15 Novembre 2022

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 ?

dysorthographie · 15 Novembre 2022

Bonjour Patrick,
C'est exprès que tu n'utilises fso pour supprimer le répertoire et son contenu ?

patricktoulon · 15 Novembre 2022

bonjour robert
ben je sais pas chez moi avec FSO je n'ai pas de différence
je suis quand même obligé de vider le dossier avant de le supprimer donc ......

Bernard_XLD · 15 Novembre 2022

Bonjour Patrick, Robert, le forum

patricktoulon à dit:
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

Cela ressemble à un problème de rafraichissement de l'affichage du bureau ou de l'explorateur que j'ai rencontré avec les dernières versions de windows 10 et 11. Teste l'existence réelle du dossier après l'avoir supprimé, tu sauras si c'est uniquement de l'affichage ou si le dossier existe réellement jusqu'à la fermeture du fichier.

Cordialement, @+

dysorthographie · 15 Novembre 2022

Déjà je redonnerai la main à Windows

Code:

Doevents
FSO.DeleteFolder DelRepertoire, True

Recherche & référence - FS0(S)

Tout ce que vous vouliez savoir sur FSOsans avoir osé le demander! 'Permet de vérifier si le répertoire dont le nom est précisé en paramêtre (Repertoires) existe. Retourne True s'il existe, sinon False Public Function Repertoires_Existe(Repertoires) Dim FSO Set FSO =...

excel-downloads.com

patricktoulon · 15 Novembre 2022

Bonjour bernard
oui ca me parait etre cela aussi
robert je vais tester

patricktoulon · 15 Novembre 2022

bon j'ai testé
c'est bien le rafraîchissement d’écran qui se fait pas
le dir vbdirectory me renvoie rien
j'ai testé fso aussi; rien ne change

bizarre quand même ce truc

merci à tous

patricktoulon · 15 Novembre 2022

re
reste à régler quand même le 2d problème
copyobjectwithcell qui a false copie quand même

patricktoulon · 16 Novembre 2022

re
bonjour a tous
donc personne a d'idée sur la question ?

Bernard_XLD · 16 Novembre 2022

Re,

Un petit fichier de test ?
Personnellement, je n'ai pas envie de devoir monter moi même un fichier pour creuser la question.

Cordialement, @+

patricktoulon · 16 Novembre 2022

Bonjour bernard
oui bien sur le voici

Bernard_XLD · 16 Novembre 2022

Re,

Apparemment, dès qu'on utilise pictures.paste ou Copypicture, la copie est décorrélée du tampon, se fait à partir du range source et n'est pas impactée par Application.CopyObjectsWithCells = False
Comme cela, ça fonctionne

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
        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
                    OBJ2.Visible = False
                Next OBJ2
                sh.Copy    'copie de la l'object itéré dans la boucle
                ActiveSheet.Pictures.Paste    'colle en tant qu'image  dans le new classeur
                For Each OBJ2 In sh.Parent.Shapes
                    OBJ2.Visible = True
                Next OBJ2
           Else
                Nom = Replace(sh.Name, " ", "_") & ".png"
                sh.Copy    'copie de la 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

    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

alors que comme cela, ça ne fonctionne plus, les objets sont quand même copiés, le .copy se faisant pourtant après le désaffichage des objets mais le paste après leur réaffichage, d'où décorrélation du tampon et de la copie effective.

Code:

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
        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
                    OBJ2.Visible = False
                Next OBJ2
                sh.Copy    'copie de la l'object itéré dans la boucle
                For Each OBJ2 In sh.Parent.Shapes
                    OBJ2.Visible = True
                Next OBJ2
                ActiveSheet.Pictures.Paste    'colle en tant qu'image  dans le new classeur
           Else
                Nom = Replace(sh.Name, " ", "_") & ".png"
                sh.Copy    'copie de la 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

    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

patricktoulon · 16 Novembre 2022

re
merci Bernard j'avais testé cette solution(shapes visible/invisible)
par contre moi j'avis choisi que les intersect(obj,topleftcel)
mais elle ne m'avait pas séduit pourtant effectivement ça semble être la seule solution

ça m'ennuie car ca m'oblige a modifier la source donc enclencher le "enregistrer" à la fermeture du fichier dans le quel je copie

patricktoulon · 16 Novembre 2022

bon merci bernard j'adopte
un dernier petit detail
l'image du range s'enregistre en fond transparent
je n'arrive pas a remettre un fond blanc
j'ai pourtant enregistrer la macro en le faisant manuellement

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    'colle en tant qu'image  dans le new classeur
                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

Bernard_XLD · 16 Novembre 2022

Re,

mets un fond blanc sur tes cellules au lieu d'"aucune couleur" et ça le fera

Cordialement, @+

Effectuez une recherche sur Excel Downloads...

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

patricktoulon

XLDnaute Barbatruc

Bernard_XLD

dysorthographie

XLDnaute Accro

patricktoulon

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

Recherche & référence - FS0(S)

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums