AW: Makroanpassung
03.02.2009 08:02:57
Ernst
Hallo Rainer !
Guten Morgen.
Es war mein Fehler habe die Codezeilen jetzt richtig eingefügt,(Makro läuft Fehlerfrei)jedoch bei öffnen einer Datei obwohl diese gerade in Verwendung ist kommt keine Msg Info Meldung ? Ich kann die Datei öffnen und die geöffnete wird geschlossen.
Funktioniert das nur wenn versucht wird die Datei über ein Netzlaufwerk zweimal zu öffnen ?
Wäre für Lösung dankbar.
lg.Ernst
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex _
As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex _
As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal _
hwnd As Long) As Long
Private Const GWL_STYLE As Long = -16
Private Const WS_SYSMENU As Long = &H80000
Private hWndForm As Long
Private bCloseBtn As Boolean
Private Sub UserForm_Initialize()
If Val(Application.Version) >= 9 Then
hWndForm = FindWindow("ThunderDFrame", Me.Caption)
Else
hWndForm = FindWindow("ThunderXFrame", Me.Caption)
End If
bCloseBtn = False
SetUserFormStyle
End Sub
Private Sub SetUserFormStyle()
Dim frmStyle As Long
If hWndForm = 0 Then Exit Sub
frmStyle = GetWindowLong(hWndForm, GWL_STYLE)
If bCloseBtn Then
frmStyle = frmStyle Or WS_SYSMENU
Else
frmStyle = frmStyle And Not WS_SYSMENU
End If
SetWindowLong hWndForm, GWL_STYLE, frmStyle
DrawMenuBar hWndForm
End Sub
Private Sub optCloseOn_Click()
bCloseBtn = True
cmdBeenden.Cancel = True
SetUserFormStyle
End Sub
Private Sub optCloseOff_Click()
bCloseBtn = False
cmdBeenden.Cancel = False
SetUserFormStyle
End Sub
' ---------------------------------------------------------------------------
Private Sub Calendar1_Click()
Dim antwort As Variant
Dim Eigenschaft
Dim blnVorhanden As Boolean
Dim MyVorlage As String, MyDatei As String
Dim Pos As Integer
Dim MyVerzeichnisNeu As String, MyDateinameNeu As String
Dim MyDateinameDatum As String
Dim strSuchOrdner As String, strSearchPath As String
Dim strMyFileName As String
Dim dtmSearchDate As Date
Dim lngFilesInFolder As Long
Dim i As Long
strSuchOrdner = "Reparaturbuch"
Unload UserForm1
antwort = MsgBox("Wenn Sie mit JA weitermachen wird ein bestehendes Reparaturbuch geöffnet" & _
Chr(10) & _
"bzw. wenn noch kein Reparaturbuch mit dem ausgewähltem Datum besteht, dann wird ein neues" & _
Chr(10) & _
"Reparaturbuch auf der Basis der letzten vorhandenen Reparaturbuchdatei erstellt. Wollen Sie _
das ?", vbYesNo, "Weitermachen oder Zurück zur Auswahl")
If antwort = vbYes Then
' es wird immer die Datei mit dem jüngsten Datum im Unterordner \Reparaturbuch gesucht und
' als Vorlage für die neue Datei mit dem aktuellen Datum verwendet. Eine Abspeicherung über
' docProperty entfällt somit !
' Es werden jedoch nur max 100 Tage zurückgerechnet, wenn in diesem Zeitraum keine Datei mit _
dem
' entsprechenden Datum vorliegt, dann gibts ein Problem - dh. das Makro wird gestoppt
'Prüfen ob der Ordner \Reparaturbuch existiert
strSearchPath = ThisWorkbook.Path & "\" & strSuchOrdner
If CheckIfFolderExists(strSearchPath) = False Then
MsgBox "Das Verzeichnis " & strSearchPath & " existiert nicht." & Chr(10) & _
"Zur Ausführung der folgenden Aktionen ist es jedoch unbedingt erforderlich !"
Exit Sub
End If
'Prüfen ob Dateien im Ordner enthalten sind - ggf. wieviele
lngFilesInFolder = CountFilesInFolder(strSearchPath)
If lngFilesInFolder > 0 Then
' Dateinamen generieren aus dem aktuellen Systemdatum
dtmSearchDate = Calendar1.Value 'Date
strMyFileName = Format(dtmSearchDate, "DD.MM.YYYY.DDD") & ".xls"
' prüfen ob eine Datei mit dem ausgwählten Datum vorhanden ist. Diese dann einfach auswä _
hlen.
' Es muss in dem Fall keine neue Datei aus einer Vorlage erstellt werden.
If CheckFileExists(strSearchPath & "\" & strMyFileName) = True Then
MsgBox "Zu Ihrer Information ! " & Chr(10) & "Ein Reparaturbuch mit diesem Datum _
ist bereits vorhanden! " & Chr(10) & _
"Es wird dieses Reparaturbuch verwendet und kein neues" & Chr(10) & " _
Reparaturbuch angelegt!", vbOKOnly, "Hinweis"
Application.DisplayAlerts = False
Dim chkWkb As Workbook
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set chkWkb = Workbooks.Open(strSearchPath & "\" & strMyFileName)
If chkWkb.ReadOnly = True Then
MsgBox "Datei wird gerade bearbeitet, bitte später nochmal probieren", vbInformation + vbOKOnly, _
"Fehler"
chkWkb.Close False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ThisWorkbook.Save
ThisWorkbook.Close
Application.DisplayAlerts = True
Exit Sub
Else ' in diesem Fall muss eine neue Datei aus einer Vorlage erstellt werden
For i = 1 To 100 ' ---------> ggf. anpassen hier werden 100 Tage von heute aus zurü _
ckgerechnet
dtmSearchDate = DateSerial(Year(dtmSearchDate), Month(dtmSearchDate), Day( _
dtmSearchDate) - 1)
strMyFileName = Format(dtmSearchDate, "DD.MM.YYYY.DDD") & ".xls"
If CheckFileExists(strSearchPath & "\" & strMyFileName) = True Then
' dann diese Datei als Vorlagedatei verwenden und daraus die aktuelle _
Datei erstellen
MsgBox "Es wird aus der Vorlage " & Chr(10) & _
strSearchPath & "\" & strMyFileName & Chr(10) & _
"das neue Reparaturbuch erstellt !"
MyVorlage = strSearchPath & "\" & strMyFileName
MyVerzeichnisNeu = strSearchPath
MyDateinameNeu = Format(Calendar1.Value, "DD.MM.YYYY.DDD") & ".xls"
MyDateinameDatum = Format(Calendar1.Value, "DD.MM.YYYY")
FileCopy MyVorlage, MyVerzeichnisNeu & "\" & MyDateinameNeu
Application.DisplayAlerts = False
Workbooks.Open MyVerzeichnisNeu & "\" & MyDateinameNeu
'Blattschutz aufheben
With Worksheets("Reparaturbuch")
.Unprotect ' ggf Passwort eingeben
.Cells(2, 2).Value = MyDateinameDatum
' Blattschutz setzen
.Protect
End With
ThisWorkbook.Save
ThisWorkbook.Close
Application.DisplayAlerts = True
Exit For
End If
Next i
End If ' Reparaturbuch gefunden/nicht gefunden mit dem ausgewähltem Datum
Else ' im Ordner REPARATURBUCH sind keine xls-Dateien enthalten !
MsgBox "Der ausgewählte Ordner " & strSearchPath & "enthält keine Dateien." & Chr(10) & _
"Zur Ausführung der nächsten Aktionen ist es jedoch erforderlich dass zumindest eine Datei _
als Vorlage vorhanden ist !"
Application.DisplayAlerts = False
ThisWorkbook.Close
Application.DisplayAlerts = True
'exit sub
End If
Else ' es soll keine neue Arbeitsmappe auf basis einer Vorlagedatei erstellt werden
ActiveWorkbook.Close
End If
End Sub
Private Sub UserForm_Activate()
Me.Calendar1.Value = Date
End Sub