XL 2016 Fermer Fichier si ouvert

[KTM]

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

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]

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

 

[job75]

Bonjour KTM, -Thierry,

Quand Liste.pdf est fermé il est écrasé pas de soucis
Mais quand il est déjà ouvert j'ai une erreur.

Chez moi sur Excel 2019 cela ne crée pas d'erreur quand il est ouvert.

A+

 

[kiki29]

Salut, dans le genre brutal et bestial, à affiner

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

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

 

[_Thierry]

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

 

[KTM]

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

OUI déjà ouvert par moi sur mon PC. Merci

 

[_Thierry]

Re bonsoir
Alors fais un essai avec la solution "meurtrière" 😉 de Kiki ! (Si tu utilses Adobe Acrobat Reader, of course !)
Bonne soirée
@+Thierry

 

[kiki29]

Re, moins assassine

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