Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Fehler abfangen | Herbers Excel-Forum


Betrifft: Fehler abfangen von: Markus
Geschrieben am: 09.12.2009 17:33:21

Hallo zusammen,

auf der Arbeit haben wir pro Gruppe eine Urlaubsplanung. Beim schliessen der Originaldatei wird _ eine Kopie auf dem Gruppenlaufwerk angelegt. Die Originaldatei steht woanders ab.

Private Sub Workbook_BeforeClose(Cancel As Boolean)

  
'Ausgangsposition einnehmen und sichern
    [d10].Activate
    ActiveSheet.Protect ("fritz"), DrawingObjects:=True, Contents:=True, Scenarios:=True,  _
AllowFiltering:=True
    ActiveSheet.EnableSelection = xlNoSelection
    ActiveWorkbook.Save

'Kopie speichern
    Sheets("Gruppe xy").Copy
    ActiveSheet.Protect ("fritz"), DrawingObjects:=True, Contents:=True, Scenarios:=True,  _
AllowFiltering:=True
    ActiveSheet.EnableSelection = xllockedcells
    ActiveWorkbook.SaveCopyAs Filename:="P:\Org_1_Mitarbeiter\Kopie von Urlaubsplan 2010.xls"
    ActiveWorkbook.Close savechanges:=False
    End Sub

Das Original wird also immer gespeichert. Bei der Kopie gibt es ab und zu Probleme.

a) Derjenige, der speichert, hat keinen Zugriff auf das Gruppenlaufwerk
b) Die Kopie ist gerade geöffnet.

Meine Frage wäre. Kann man diesen Fehler umgehen? Mir schwebt vor, wenn man die Kopie nicht anlegen bzw. überschreiben kann, so erhält man beispielsweise eine Msgbox "Kopie derzeit nicht speicherbar", man kommt aus Excel aber vernünftig raus. Derzeit ist nur ein harter Abbruch ohne Anlage einer Kopie möglich.

Bin über jede Idee dankbar!

Viele Grüße
Markus

  

Betrifft: AW: Fehler abfangen von: Josef Ehrensberger
Geschrieben am: 09.12.2009 17:54:25

Hallo Markus,

probier mal.

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  
  'Ausgangsposition einnehmen und sichern
  With ActiveSheet
    .[d10].Activate
    .Protect "fritz", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
      AllowFiltering:=True
    .EnableSelection = xlNoSelection
  End With
  ActiveWorkbook.Save
  
  'Kopie speichern
  If FileStatus("P:\Org_1_Mitarbeiter\Kopie von Urlaubsplan 2010.xls") = XL_CLOSED Then
    Sheets("Gruppe xy").Copy
    With ActiveSheet
      .Protect "fritz", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
        AllowFiltering:=True
      .EnableSelection = xllockedcells
    End With
    ActiveWorkbook.SaveCopyAs Filename:="P:\Org_1_Mitarbeiter\Kopie von Urlaubsplan 2010.xls"
    ActiveWorkbook.Close
  Else
    MsgBox "Kopie derzeit nicht speicherbar!", vbInformation, "Hinweis"
  End If
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Public Enum XL_FILESTATUS
  XL_UNDEFINED = -1
  XL_CLOSED
  XL_OPEN
  XL_DONTEXIST
End Enum

Public Function FileStatus(xlFile As String) As XL_FILESTATUS
  
  On Error Resume Next
  
  Dim File%: File = FreeFile
  
  Err.Clear
  
  Open xlFile For Input Access Read Lock Read As #File
  Close #File
  
  Select Case Err.Number
    Case 0: FileStatus = XL_CLOSED
    Case 70: FileStatus = XL_OPEN
    Case 76: FileStatus = XL_DONTEXIST
    Case Else: FileStatus = XL_UNDEFINED
  End Select
  
End Function



Gruß Sepp



  

Betrifft: AW: Fehler abfangen von: Markus
Geschrieben am: 09.12.2009 19:35:38

Hallo Sepp,

bekomme den Hinweis "Fehler beim Kompilieren: Benutzerdefiniert Typ nicht definiert"

Verstehe nur Bahnhof. :-) Kann es daran liegen dass die Kopie noch gar nicht vorhanden ist? Sie wird ja erst beim ersten speichern angelegt.

Viele Grüße
Markus


  

Betrifft: AW: Fehler abfangen von: Josef Ehrensberger
Geschrieben am: 09.12.2009 20:21:47

Hallo Markus,

das hast du aber anders beschrieben.

Zitat:
a) Derjenige, der speichert, hat keinen Zugriff auf das Gruppenlaufwerk
b) Die Kopie ist gerade geöffnet.


Wenn du eine Fehlermeldung erhälst, dann hast du entweder nicht den gesamten Code eingefügt,
oder du hast den Code in die Falschen Module/Klassenmodule eingefügt.


Probier mal diesen Code und achte darauf, wo die jeweiligen Codeabschnitte hingehören.


' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim AccesWrite As Boolean, strFile As String, strPath As String
  
  'Ausgangsposition einnehmen und sichern
  With ActiveSheet
    .[d10].Activate
    .Protect "fritz", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
      AllowFiltering:=True
    .EnableSelection = xlNoSelection
  End With
  ActiveWorkbook.Save
  
  'Kopie speichern
  
  strPath = "P:\Org_1_Mitarbeiter\"
  
  strFile = "Kopie von Urlaubsplan 2010.xls"
  
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  
  If Dir(strPath & strFile, vbNormal) <> "" Then
    AccesWrite = CheckFileAccess(strPath & strFile, FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE
  Else
    AccesWrite = CheckFileAccess(strPath, FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE
  End If
  If AccesWrite Then
    Sheets("Gruppe xy").Copy
    With ActiveSheet
      .Protect "fritz", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
        AllowFiltering:=True
      .EnableSelection = xlUnlockedCells
    End With
    ActiveWorkbook.SaveCopyAs Filename:=strPath & strFile
    ActiveWorkbook.Close
  Else
    MsgBox "Kopie derzeit nicht speicherbar!", vbInformation, "Hinweis"
  End If
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit
' ********************************************
' * ¸ 2000 Sergey Merzlikin *
' ********************************************

' Desired access rights constants
Public Const MAXIMUM_ALLOWED As Long = &H2000000
Public Const DELETE As Long = &H10000
Public Const READ_CONTROL As Long = &H20000
Public Const WRITE_DAC As Long = &H40000
Public Const WRITE_OWNER As Long = &H80000
Public Const SYNCHRONIZE As Long = &H100000
Public Const STANDARD_RIGHTS_READ As Long = READ_CONTROL
Public Const STANDARD_RIGHTS_WRITE As Long = READ_CONTROL
Public Const STANDARD_RIGHTS_EXECUTE As Long = READ_CONTROL
Public Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Public Const FILE_READ_DATA As Long = &H1 ' file & pipe
Public Const FILE_LIST_DIRECTORY As Long = &H1 ' directory
Public Const FILE_ADD_FILE As Long = &H2 ' directory
Public Const FILE_WRITE_DATA As Long = &H2 ' file & pipe
Public Const FILE_CREATE_PIPE_INSTANCE As Long = &H4 ' named pipe
Public Const FILE_ADD_SUBDIRECTORY As Long = &H4 ' directory
Public Const FILE_APPEND_DATA As Long = &H4 ' file
Public Const FILE_READ_EA As Long = &H8 ' file & directory
Public Const FILE_READ_PROPERTIES As Long = FILE_READ_EA
Public Const FILE_WRITE_EA As Long = &H10 ' file & directory
Public Const FILE_WRITE_PROPERTIES As Long = FILE_WRITE_EA
Public Const FILE_EXECUTE As Long = &H20 ' file
Public Const FILE_TRAVERSE As Long = &H20 ' directory
Public Const FILE_DELETE_CHILD As Long = &H40 ' directory
Public Const FILE_READ_ATTRIBUTES As Long = &H80 ' all
Public Const FILE_WRITE_ATTRIBUTES As Long = &H100 ' all
Public Const FILE_GENERIC_READ As Long = (STANDARD_RIGHTS_READ _
  Or FILE_READ_DATA Or FILE_READ_ATTRIBUTES _
  Or FILE_READ_EA Or SYNCHRONIZE)
Public Const FILE_GENERIC_WRITE As Long = (STANDARD_RIGHTS_WRITE _
  Or FILE_WRITE_DATA Or FILE_WRITE_ATTRIBUTES _
  Or FILE_WRITE_EA Or FILE_APPEND_DATA Or SYNCHRONIZE)
Public Const FILE_GENERIC_EXECUTE As Long = (STANDARD_RIGHTS_EXECUTE _
  Or FILE_READ_ATTRIBUTES Or FILE_EXECUTE Or SYNCHRONIZE)
Public Const FILE_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED _
  Or SYNCHRONIZE Or &H1FF&)
Public Const GENERIC_READ As Long = &H80000000
Public Const GENERIC_WRITE As Long = &H40000000
Public Const GENERIC_EXECUTE As Long = &H20000000
Public Const GENERIC_ALL As Long = &H10000000

' Types, constants and functions
' to work with access rights
Public Const OWNER_SECURITY_INFORMATION As Long = &H1
Public Const GROUP_SECURITY_INFORMATION As Long = &H2
Public Const DACL_SECURITY_INFORMATION As Long = &H4
Public Const TOKEN_QUERY As Long = 8
Public Const SecurityImpersonation As Integer = 3
Public Const ANYSIZE_ARRAY = 1
Public Type GENERIC_MAPPING
  GenericRead As Long
  GenericWrite As Long
  GenericExecute As Long
  GenericAll As Long
End Type
Public Type LUID
  LowPart As Long
  HighPart As Long
End Type
Public Type LUID_AND_ATTRIBUTES
  pLuid As LUID
  Attributes As Long
End Type
Public Type PRIVILEGE_SET
  PrivilegeCount As Long
  Control As Long
  Privilege(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type
Public Declare Function GetFileSecurity Lib "advapi32.dll" _
  Alias "GetFileSecurityA" (ByVal lpFileName As String, _
  ByVal RequestedInformation As Long, pSecurityDescriptor As Byte, _
  ByVal nLength As Long, lpnLengthNeeded As Long) As Long
Public Declare Function AccessCheck Lib "advapi32.dll" _
  (pSecurityDescriptor As Byte, ByVal ClientToken As Long, _
  ByVal DesiredAccess As Long, GenericMapping As GENERIC_MAPPING, _
  PrivilegeSet As PRIVILEGE_SET, PrivilegeSetLength As Long, _
  GrantedAccess As Long, Status As Long) As Long
Public Declare Function ImpersonateSelf Lib "advapi32.dll" _
  (ByVal ImpersonationLevel As Integer) As Long
Public Declare Function RevertToSelf Lib "advapi32.dll" () As Long
Public Declare Sub MapGenericMask Lib "advapi32.dll" (AccessMask As Long, _
  GenericMapping As GENERIC_MAPPING)
Public Declare Function OpenThreadToken Lib "advapi32.dll" _
  (ByVal ThreadHandle As Long, ByVal DesiredAccess As Long, _
  ByVal OpenAsSelf As Long, TokenHandle As Long) As Long
Public Declare Function GetCurrentThread Lib "kernel32" () As Long
Public Declare Function CloseHandle Lib "kernel32" _
  (ByVal hObject As Long) As Long

' Types, constants and functions for OS version detection
Public Type OSVERSIONINFO
  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion As String * 128
End Type
Public Const VER_PLATFORM_WIN32_NT As Long = 2
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long

' Constant and function for detection of support
' of access rights by file system
Public Const FS_PERSISTENT_ACLS As Long = &H8
Public Declare Function GetVolumeInformation Lib "kernel32" _
  Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
  ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
  lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
  lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
  ByVal nFileSystemNameSize As Long) As Long


' *-----------------------------------------------------------------------*
' CheckFileAccess function checks access rights to given file.
' DesiredAccess - bitmask of desired access rights.
' The function returns bitmask, which contains those bits of desired bitmask,
' which correspond with existing access rights.
Public Function CheckFileAccess(Filename As String, _
    ByVal DesiredAccess As Long) As Long

  Dim r As Long, SecDesc() As Byte, SDSize As Long, hToken As Long
  Dim PrivSet As PRIVILEGE_SET, GenMap As GENERIC_MAPPING
  Dim Volume As String, FSFlags As Long
  ' Checking OS type
  If Not IsNT() Then
    ' Rights not supported. Returning -1.
    CheckFileAccess = -1
    Exit Function
  End If
  ' Checking access rights support by file system
  If Left$(Filename, 2) = "\\" Then
    ' Path in UNC format. Extracting share name from it
    r = InStr(3, Filename, "\")
    If r = 0 Then
      Volume = Filename & "\"
    Else
      Volume = Left$(Filename, r)
    End If
  ElseIf Mid$(Filename, 2, 2) = ":\" Then
    ' Path begins with drive letter
    Volume = Left$(Filename, 3)
    'Else
    ' If path not set, we are leaving Volume blank.
    ' It retutns information about current drive.
  End If
  ' Getting information about drive
  GetVolumeInformation Volume, vbNullString, 0, ByVal 0&, _
    ByVal 0&, FSFlags, vbNullString, 0
  If (FSFlags And FS_PERSISTENT_ACLS) = 0 Then
    ' Rights not supported. Returning -1.
    CheckFileAccess = -1
    Exit Function
  End If
  ' Determination of buffer size
  GetFileSecurity Filename, OWNER_SECURITY_INFORMATION _
    Or GROUP_SECURITY_INFORMATION _
    Or DACL_SECURITY_INFORMATION, 0, 0, SDSize
  If Err.LastDllError <> 122 Then
    ' Rights not supported. Returning -1.
    CheckFileAccess = -1
    Exit Function
  End If
  If SDSize = 0 Then Exit Function
  ' Buffer allocation
  Redim SecDesc(1 To SDSize)
  ' Once more call of function
  ' to obtain Security Descriptor
  If GetFileSecurity(Filename, OWNER_SECURITY_INFORMATION _
    Or GROUP_SECURITY_INFORMATION _
    Or DACL_SECURITY_INFORMATION, _
    SecDesc(1), SDSize, SDSize) = 0 Then
    ' Error. We must return no access rights.
    Exit Function
  End If
  ' Adding Impersonation Token for thread
  ImpersonateSelf SecurityImpersonation
  ' Opening of Token of current thread
  OpenThreadToken GetCurrentThread(), TOKEN_QUERY, 0, hToken
  If hToken <> 0 Then
    ' Filling GenericMask type
    GenMap.GenericRead = FILE_GENERIC_READ
    GenMap.GenericWrite = FILE_GENERIC_WRITE
    GenMap.GenericExecute = FILE_GENERIC_EXECUTE
    GenMap.GenericAll = FILE_ALL_ACCESS
    ' Conversion of generic rights
    ' to specific file access rights
    MapGenericMask DesiredAccess, GenMap
    ' Checking access
    AccessCheck SecDesc(1), hToken, DesiredAccess, GenMap, _
      PrivSet, Len(PrivSet), CheckFileAccess, r
    CloseHandle hToken
  End If
  ' Deleting Impersonation Token
  RevertToSelf
End Function

' *-----------------------------------------------------------------------*
' IsNT() function returns True, if the program works
' in Windows NT or Windows 2000 operating system, and False
' otherwise.
Private Function IsNT() As Boolean
  Dim OSVer As OSVERSIONINFO
  OSVer.dwOSVersionInfoSize = Len(OSVer)
  GetVersionEx OSVer
  IsNT = (OSVer.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function

' *-----------------------------------------------------------------------*

Sub hhh()
  Dim l As Long
  l = CheckFileAccess("E:\Temp\Test\Druckbereich.xls", FILE_GENERIC_WRITE)
End Sub



Gruß Sepp



  

Betrifft: AW: Fehler abfangen von: Markus
Geschrieben am: 09.12.2009 20:41:09

Hallo Sepp,

ja hatte in der Tat übersehen, dass ich die Funktion in ein Modul packen musste. Sorry!
Der Fehler kommt aber leider immer noch. Noch ein Fehler von mir? Dann suche ich.


Mit dem speichern ist das so eine Sache. In der Regel macht es der Gruppenleiter. Da klappt das speichern der Kopie natürlich, weil er für sein Gruppenlaufwerk berechtigt ist. Hier kann es also nur scheitern, wenn gerade ein Mitarbeiter die Kopie geöffnet hat.

Der andere Fall ist: Ein Vertreter oder der AL speichert eine Änderung im Original. Die haben natürlich keinen Zugriff auf das Laufwerk und dementsprechend kann auch die Kopie nicht gespeichert werden.

Ist die erste Lösung dadurch hinfällig? Ich frage, wei ich mich vor dem langen Code drücken möchte. :-)

Sorry für die Mehrarbeit.


  

Betrifft: AW: Fehler abfangen von: Markus
Geschrieben am: 09.12.2009 21:32:49

Hallo Sepp,

ich habe den langen Code eingefügt. Zusätzlich habe ich noch das eingefügt:

Application.DisplayAlerts = False
ActiveWorkbook.SaveCopyAs Filename:=strPath & strFile
ActiveWorkbook.Close


Application.DisplayAlerts = True


Hintergrund ist, dass ja eine Mappe geniert wird (z.B. Mappe 14) und Excel fragt, ob die gespeichert werden soll. Wäre das sinnvoll?

Der Komplimierungsfehler kommt beim öffnen immer noch. Nehme ich folgende Zeile raus, dann ist alles gut.

ActiveSheet.EnableSelection = xllockedcells

Mir ist die Funktion nicht bewusst. Die Hilfe verstehe ich nicht. Kann ich auf den Code verzichten? Beim schliesen habe ich eine ähnlichen Code gefunden. Zerschiess ich mir da was, wenn ich das rauslasse?
Ich habe die Datei leider geerbt.

Nochmals danke für Deine Hilfe!

Gruß
Markus


  

Betrifft: AW: Fehler abfangen von: Josef Ehrensberger
Geschrieben am: 09.12.2009 21:44:26

Hallo Markus,

tipst du den Code ab? Copy-Paste kennst du aber schon?

Der Fehler kommt, weil es nich xllockedcells sondern xlUnlockedCells heißt.

Den Code der ersten lösung kannst du wegwerfen.

Da du ja ein neues WorkBook erstellst, brauchst du auch nicht .SaveCopyAs sondern .SaveAs,
dadurch wird auch .DisplayAlerts überflüssig. Ersetze den Code im Klassenmodul der Tabelle
durch den folgenden. Der Code im allgemeinen Modul bleibt unberührt!

' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
  Dim AccesWrite As Boolean, strFile As String, strPath As String
  
  'Ausgangsposition einnehmen und sichern
  With ActiveSheet
    .[d10].Activate
    .Protect "fritz", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
      AllowFiltering:=True
    .EnableSelection = xlNoSelection
  End With
  ActiveWorkbook.Save
  
  'Kopie speichern
  
  strPath = "P:\Org_1_Mitarbeiter\"
  
  strFile = "Kopie von Urlaubsplan 2010.xls"
  
  If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
  
  If Dir(strPath & strFile, vbNormal) <> "" Then
    AccesWrite = CheckFileAccess(strPath & strFile, FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE
  Else
    AccesWrite = CheckFileAccess(strPath, FILE_GENERIC_WRITE) = FILE_GENERIC_WRITE
  End If
  If AccesWrite Then
    Sheets("Gruppe xy").Copy
    With ActiveSheet
      .Protect "fritz", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
        AllowFiltering:=True
      .EnableSelection = xlUnlockedCells
    End With
    ActiveWorkbook.SaveAs Filename:=strPath & strFile
    ActiveWorkbook.Close True
  Else
    MsgBox "Kopie derzeit nicht speicherbar!", vbInformation, "Hinweis"
  End If
End Sub



Gruß Sepp



  

Betrifft: danke für Deine Hilfe von: Markus
Geschrieben am: 09.12.2009 22:55:54




Beiträge aus den Excel-Beispielen zum Thema "Fehler abfangen"