XL 2016 Fermer Fichier si ouvert

KTM

XLDnaute Impliqué
Salut chers tous
Ma macro suivante exporte ma plage au format pdf en lui donnant le nom "Liste.pdf"
Quand Liste.pdf est fermé il est écrasé pas de soucis
Mais quand il est déjà ouvert j'ai une erreur.
Je voudrais insérer dans ma macro un code pour fermer Liste.pdf si ouvert avant de l’écraser. Merci

VB:
Sub export()
Dim chemin, NomPDF As String
    chemin = ThisWorkbook.Path & "\PREVUS\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
With ActiveSheet
    NomPDF = "Liste"
    .PageSetup.PrintArea = "$A$1:$I$50"
    .PageSetup.FitToPagesWide = 1
    .PageSetup.FitToPagesTall = False
    .PageSetup.RightFooter = "&P de &N"
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin & NomPDF, Quality:=xlQualityStandard
End With
End Sub
 

_Thierry

XLDnaute Barbatruc
Bonsoir @KTM, le Forum

Juste une question, ouvert par toi ? ou par quelqu'un dans le réseau ?

Si c'est que sur ta propre session, il faut faire un loop sur les ActiveWindows je pense..
Si c'est en réseau je ne vois pas de solution mis à part d'envoyer du NetSend "Fermer le fichier liste.pdf !!!" ou un mail ... Mais tout dépend des régles de sécurité de ton NetWork Admin..

Bonne soirée
@+Thierry
 

kiki29

XLDnaute Barbatruc
Salut, dans le genre brutal et bestial, à affiner
VB:
Option Explicit

Sub export()
Dim sChemin As String, sNomPDF As String
Dim FSO As Object

    sChemin = ThisWorkbook.Path
    sNomPDF = "Liste.pdf"
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sChemin & "\" & sNomPDF) Then
        If IsFileOpen(sChemin & "\" & sNomPDF) Then
            KillAcrobat
        End If
        Set FSO = Nothing
    End If

    With ActiveSheet
        .PageSetup.PrintArea = "$A$1:$I$50"
        .PageSetup.FitToPagesWide = 1
        .PageSetup.FitToPagesTall = False
        .PageSetup.RightFooter = "&P de &N"
        .ExportAsFixedFormat Type:=xlTypePDF, _
                             filename:=sChemin & "\" & sNomPDF, _
                             Quality:=xlQualityStandard, _
                             OpenAfterPublish:=True
    End With
End Sub

Private Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer
    '   Turn error checking Off.
    On Error Resume Next
    filenum = FreeFile()

    Open filename For Input Lock Read As #filenum
    Close filenum
    '   Save the error number that occurred.
    errnum = Err
    '   Turn error checking back On.
    On Error GoTo 0

    Select Case errnum
        '   No error occurred.
        '   File is NOT already open by another user.
    Case 0
        IsFileOpen = False
        '   Error number for "Permission Denied."
        '   File is already opened by another user.
    Case 70
        IsFileOpen = True
        '   Another error occurred, file is being queried.
    Case Else
        Error errnum
    End Select
End Function

Private Sub KillAcroRd32()
Dim RetVal As Long
    RetVal = Shell("Taskkill /im AcroRd32.exe /t /f", 0)
End Sub

Private Sub KillAcrobat()
Dim RetVal As Long
    RetVal = Shell("Taskkill /im Acrobat.exe /f", 0)
End Sub

une autre plus douce à adapter
Code:
Option Explicit

Sub export()
Dim sChemin As String, sNomPDF As String
Dim FSO As Object

    sChemin = ThisWorkbook.Path
    sNomPDF = "Liste.pdf"

    sNomPDF = RenommerFichier(sChemin, sNomPDF)
    With ActiveSheet
        .PageSetup.PrintArea = "$A$1:$I$50"
        .PageSetup.FitToPagesWide = 1
        .PageSetup.FitToPagesTall = False
        .PageSetup.RightFooter = "&P de &N"
        .ExportAsFixedFormat Type:=xlTypePDF, _
                             filename:=sNomPDF, _
                             Quality:=xlQualityStandard, _
                             OpenAfterPublish:=True
    End With
End Sub

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function
 
Dernière édition:

_Thierry

XLDnaute Barbatruc
Bonsoir à tous

KTM n'a pas répondu si c'était en réseau ou pas, car c'est important.

Pour Job, même avec le même nom il te laisse écraser un PDF ouvert même avec Excel 2019 ca me parait bizarre ...

Pour kiki, oui donc à deux conditions, ouvert par KTM lui même sur sa session, et ouvert avec Acrobat Reader (pas avec d'autres freeware "Foxit", "Slim", "Nitro", "Expert" et "Jean" Passe ...;)

Bonne soirée
@+Thierry
 

kiki29

XLDnaute Barbatruc
Re, moins assassine
VB:
Option Explicit

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" _
                                     (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
                                      lParam As Any) As Long

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                                    (ByVal lpClassname As String, ByVal lpWindowName As String) As Long

Private Const WM_CLOSE = &H10

Sub Test()
Dim Hwnd As Long

    Hwnd = FindWindow(vbNullString, "Liste.pdf - Adobe Acrobat Reader DC")

    If Hwnd Then PostMessage Hwnd, WM_CLOSE, 0, ByVal 0&
End Sub
 
Dernière édition:
Haut Bas