Controleren of een excel bestand open staat 2

Ron321 · 26 nov 2006

Hoi mulderm,

It's a simple

Code:

Sub CloseOpenFiles()

Dim openXls As Workbook

For Each openXls In Excel.Workbooks
    retval = MsgBox(openXls.Name & " staan open" & vbCrLf & "Wilt u deze sluiten?", vbQuestion + vbYesNo)
    If retval = vbYes Then
        openXls.Close
    End If
Next

End Sub

Uit het andere topic heb ik deze code geprobeerd en het werkt maar alleen voor de werkmap waar ik op dat moment in bezig ben.
Nu zou ik willen controleren in die werkmap (bijv. test.xls) of een andere werkmap (rapporten.xls) open staat en die via de msgbox sluiten.
Is dat mogelijk en zoja hoe?

Spiderman · 26 nov 2006

Hoi Ron321,

Heb je dan iets aan de code die ook in de topic staat.
Daarbij kun je de filenaam aangeven. (maar zoals gezegt ik heb hem niet uitgeprobeert)

Code:

Function IsFileOpen(FileName As String) 
    Dim iFilenum As Long 
    Dim iErr As Long 
     
    On Error Resume Next 
    iFilenum = FreeFile() 
    Open FileName For Input Lock Read As #iFilenum 
    Close iFilenum 
    iErr = Err 
    On Error Goto 0 
     
    Select Case iErr 
    Case 0:    IsFileOpen = False 
    Case 70:   IsFileOpen = True 
    Case Else: Error iErr 
    End Select 
     
End Function 
 
Sub test() 
    If Not IsFileOpen("C:\MyTest\volker2.xls") Then 
        Workbooks.Open "C:\MyTest\volker2.xls" 
    End If 
End Sub

Ron321 · 26 nov 2006

Ik heb hem ook niet geprobeerd omdat ik die andere zo mooi vind met die msgbox.

Ron321 · 26 nov 2006

Ik heb de code getest maar daar kan ik niks mee.
Weet iemand hoe ik de eerste code aan kan passen om te bereiken wat ik wil?

Spiderman · 27 nov 2006

Oke dan. Het was ff puzzelen, maar heb de volgende code gevonden.

Code:

Function IsFileOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long
     
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0
     
    Select Case iErr
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error iErr
    End Select
     
End Function
 
Sub test()
    
    Dim retval
    Dim MyXL As Object
    
    
    If IsFileOpen("C:\test.xls") Then
        retval = MsgBox("C:\test.xls staat open" & vbCrLf & "Wilt u deze sluiten?", vbQuestion + vbYesNo)
        If retval = vbYes Then
            Set MyXL = GetObject("c:\test.xls")
            MyXL.Close
        End If

    End If
End Sub

Probeer die maar eens. c:\test.xls is het bestand dat geprobeert wordt te sluiten. Pas deze aan zodat het aansluit op je eigen bestanden

Ron321 · 27 nov 2006

Ik probeer jouw code te intregreren in de rest van mijn macro maar er gaat iets fout.
Ik krijg de melding: Er wordt een End sub verwacht , maar ik weet niet waar.

Code:

Sub opslaan()
Application.ScreenUpdating = False
Function IsFileOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long
     
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0
     
    Select Case iErr
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error iErr
    End Select
     
End Function

End Sub
    
    Dim retval
    Dim MyXL As Object
    
    
    If IsFileOpen("Rapporten.xls") Then
        retval = MsgBox("Rapporten.xls staat open" & vbCrLf & "Wilt u deze sluiten?", vbQuestion + vbYesNo)
        If retval = vbYes Then
            Set MyXL = GetObject("Rapporten.xls")
            MyXL.Close
        End If

    End If
Next
pad = Sheets(2).Range("n1").Value
If Right(pad, 1) <> "\" Then pad = pad & "\"
codeA = Sheets(3).Range("g2").Value
bestand = pad & codeA & ".xls"
bericht = "Bestand wordt opgeslagen als:" & Chr(10) & bestand & Chr(10) & "Is dit correct ?"
naam_ok = MsgBox(bericht, vbYesNo)
If naam_ok = vbYes Then
 ActiveWorkbook.SaveAs FileName:=bestand
End If

Dim VrijeRij, Directory
Application.ScreenUpdating = False
Directory = ActiveSheet.Range("N1").Value & ""
VrijeRij = 2
Range("P1:U1").Select
Selection.Copy
Workbooks.Open FileName:= _
   Directory & "\Rapporten.xls"
Do Until ActiveSheet.Cells(VrijeRij, 1).Value = ""
  ActiveSheet.Cells(VrijeRij, 1).Select
  VrijeRij = VrijeRij + 1
Loop
ActiveSheet.Cells(VrijeRij, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub

Spiderman · 27 nov 2006

Zoiets denk ik

Code:

Function IsFileOpen(FileName As String)
    Dim iFilenum As Long
    Dim iErr As Long
     
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0
     
    Select Case iErr
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error iErr
    End Select
     
End Function

Sub opslaan()
    Application.ScreenUpdating = False
    
    Dim retval
    Dim MyXL As Object
    
    
    If IsFileOpen("Rapporten.xls") Then
        retval = MsgBox("Rapporten.xls staat open" & vbCrLf & "Wilt u deze sluiten?", vbQuestion + vbYesNo)
        If retval = vbYes Then
            Set MyXL = GetObject("Rapporten.xls")
            MyXL.Close
        End If

    End If
''Next
    pad = Sheets(2).Range("n1").Value
    If Right(pad, 1) <> "" Then pad = pad & ""
        codeA = Sheets(3).Range("g2").Value
        bestand = pad & codeA & ".xls"
        bericht = "Bestand wordt opgeslagen als:" & Chr(10) & bestand & Chr(10) & "Is dit correct ?"
        naam_ok = MsgBox(bericht, vbYesNo)
        If naam_ok = vbYes Then
         ActiveWorkbook.SaveAs FileName:=bestand
        End If

    Dim VrijeRij, Directory
    Application.ScreenUpdating = False
    Directory = ActiveSheet.Range("N1").Value & ""
    VrijeRij = 2
    Range("P1:U1").Select
    Selection.Copy
    Workbooks.Open FileName:=Directory & "\Rapporten.xls"
    Do Until ActiveSheet.Cells(VrijeRij, 1).Value = ""
        ActiveSheet.Cells(VrijeRij, 1).Select
        VrijeRij = VrijeRij + 1
    Loop
    ActiveSheet.Cells(VrijeRij, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.ScreenUpdating = True
    ActiveWorkbook.Save
    ActiveWorkbook.Close
End Sub

Je had een Function in een Sub staan. Dat werkt natuurlijk nie.

Ron321 · 28 nov 2006

Krijg nu de melding: fout 53 tijdens uitvoering:kan het bestand niet vinden.
Foutopsporing begint bij:

Code:

Case Else: Error iErr

Spiderman · 28 nov 2006

Hoi Ron321,

fout 53 tijdens uitvoering:kan het bestand niet vinden.

Het bestand dat je opgeeft bij IsFileOpen(JouBestand) is niet gevonden.
Ik weet niet of je alleen je bestandsnaam opgeeft, maar het moet iig je hele Locatie + bestandsnaam zijn
Dus als voorbeeld IsFileOpen("c:\de eerste map\de tweede map\bla\test.xls"

Ron321 · 28 nov 2006

Is het dan mogelijk om de code zo aan te passen dat hij kijkt naar het bestand rapporten in de directory die verderop in de macro opgezocht wordt?

Spiderman · 28 nov 2006

Op het moment dat je de functie aanroept, moet je dus je locatie + je bestandsnaam weten. Als je je locatie uit een andere Sub/Module haalt dan zul je deze

Moeten mee nemen (bijvoorbeeld op de zelfde manier zoals bij IsFileOpen gedaan wordt, met de variable FileName)
Je de variable Boven aan in een Module declareerd (Als binnen 1 Module dan met Dim, Als in meerdere modules dan met Public)

Als je er niet uit komt, kun je dan misschien een voorbeeldje plaatsen, zodat we daarin kunnen uitlegen hoe het een en ander werkt

Ron321 · 28 nov 2006

Ik ben niet goed in macro's.
Van dit forum heb ik overal macro's (of stukjes daarvan) vandaan gehaald en die met behulp van de geduldige mensen hier aangepast.
Het bestand is veel te groot om hier te posten.
Zie je kans om de code die je als laatst gepost hebt aan te passen zodat hij naar de juiste directory kijkt?
Het bestand heet altijd "Rapporten.xls", alleen de directory is bij alle collega's anders.
Het is dezelfde directory als waar het bestand opgeslagen wordt.

Alvast enorm bedankt!

Spiderman · 28 nov 2006

Hoi Ron321,

Verander:

Code:

 If IsFileOpen("Rapporten.xls") Then

in:

Code:

    If IsFileOpen(ThisWorkbook.Path & "\\" & "Rapporten.xls") Then

ThisWorkbook.Path is dus je locatie waar je Xls bestand is opgeslagen.

Ron321 · 29 nov 2006

Het is gelukt!
Enorm bedankt Arno!
Dit is 'm geworden:

Code:

Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
    "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Function fOSUserName() As String
Application.ScreenUpdating = False
Dim lngLen As Long, lngX As Long
Dim strUserName As String
    strUserName = String$(254, 0)
    lngLen = 255
    lngX = apiGetUserName(strUserName, lngLen)
    If lngX <> 0 Then
        fOSUserName = Left$(strUserName, lngLen - 1)
    Else
        fOSUserName = ""
    End If
End Function
Function IsFileOpen(FileName As String)
Application.ScreenUpdating = False
    Dim iFilenum As Long
    Dim iErr As Long
     
    On Error Resume Next
    iFilenum = FreeFile()
    Open FileName For Input Lock Read As #iFilenum
    Close iFilenum
    iErr = Err
    On Error GoTo 0
     
    Select Case iErr
    Case 0:    IsFileOpen = False
    Case 70:   IsFileOpen = True
    Case Else: Error iErr
    End Select
     
End Function

Sub opslaan()
    Application.ScreenUpdating = False
    
    Dim retval
    Dim MyXL As Object
    
    pad = Sheets(2).Range("n1").Value
    If IsFileOpen(pad & "Rapporten.xls") Then
        retval = MsgBox("Rapporten.xls staat open" & vbCrLf & "Wilt u deze sluiten?", vbQuestion + vbYesNo)
        If retval = vbYes Then
            Set MyXL = GetObject(pad & "Rapporten.xls")
            MyXL.Close
        End If

    End If
''Next
    
    If Right(pad, 1) <> "" Then pad = pad & ""
        codeA = Sheets(3).Range("g2").Value
        bestand = pad & codeA & ".xls"
        bericht = "Bestand wordt opgeslagen als:" & Chr(10) & bestand & Chr(10) & "Is dit correct ?"
        naam_ok = MsgBox(bericht, vbYesNo)
        If naam_ok = vbYes Then
         ActiveWorkbook.SaveAs FileName:=bestand
        End If

    Dim VrijeRij, Directory
    Application.ScreenUpdating = False
    Directory = ActiveSheet.Range("N1").Value & ""
    VrijeRij = 2
    Range("P1:U1").Select
    Selection.Copy
    Workbooks.Open FileName:=Directory & "\Rapporten.xls"
    Do Until ActiveSheet.Cells(VrijeRij, 1).Value = ""
        ActiveSheet.Cells(VrijeRij, 1).Select
        VrijeRij = VrijeRij + 1
    Loop
    ActiveSheet.Cells(VrijeRij, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.ScreenUpdating = True
    ActiveWorkbook.Save
    ActiveWorkbook.Close
End Sub

Controleren of een excel bestand open staat 2

Ron321

Gebruiker

Spiderman

Gebruiker

Ron321

Gebruiker

Ron321

Gebruiker

Spiderman

Gebruiker

Ron321

Gebruiker

Spiderman

Gebruiker

Ron321

Gebruiker

Spiderman

Gebruiker

Ron321

Gebruiker

Spiderman

Gebruiker

Ron321

Gebruiker

Spiderman

Gebruiker

Ron321

Gebruiker

Nieuwste berichten

Wij waarderen jouw privacy