AW: Vormonatsdatei per Schaltfläche
05.09.2011 17:45:06
Tino
Hallo,
habe das mit dem Schließen der Datei mit einer Abfrage eingebaut u.
noch ein paar andere Zeilen anders aufgebaut wo ich meine das es so besser ist.
kommt als Code in DieseArbeitsmappe
Option Explicit
Dim oKlasseExcel As Klasse1
Private Sub Workbook_BeforeClose(Cancel As Boolean)
LoeschButton CaptionButtonZurueck, CaptionButtonVor
Set oKlasseExcel = Nothing
End Sub
Private Sub Workbook_Open()
Set oKlasseExcel = New Klasse1
Set oKlasseExcel.ExcelWatch = Application
End Sub
kommt als Code in Modul1
Option Explicit
Public Const CaptionButtonVor$ = "Vor", CaptionButtonZurueck$ = "Zurück"
Sub Suche_File(intSuchRichtung As Integer)
Dim ArrLW(), n&, strNextFile$, nStart&, sFileName$
Dim DateMMJJ As Date, oWB As Workbook, booIsOben As Boolean
Dim intAntwort As VbMsgBoxResult
'hier die beiden Pfade
ArrLW = Array("C:\Auto\", "F:\Auto\")
strNextFile = ActiveWorkbook.Name
nStart = InStrRev(strNextFile, ".") - 4
strNextFile = Mid$(strNextFile, nStart, 4)
DateMMJJ = DateSerial(Mid(strNextFile, 3, 2) * 1, Mid(strNextFile, 1, 2) * 1, 1)
DateMMJJ = DateMMJJ + intSuchRichtung
For n = Lbound(ArrLW) To Ubound(ArrLW)
If Right$(ArrLW(n), 1) <> "\" Then ArrLW(n) = ArrLW(n) & "\"
strNextFile = FindFile(ArrLW(n), "*" & Format(DateMMJJ, "mmyy") & ".xls", , "*" & Format(DateMMJJ, "mmyy") & ".xlsm")
If strNextFile <> "" Then Exit For
Next n
If strNextFile <> "" Then
sFileName = Mid$(strNextFile, InStrRev(strNextFile, "\") + 1, 10 ^ 9)
For Each oWB In Workbooks
booIsOben = oWB.Name = sFileName
If booIsOben Then Exit For
Next oWB
If Not booIsOben Then 'Datei nicht offen
intAntwort = MsgBox("Datei gefunden!" & vbCr & "Soll die aktuelle Datei '" & ActiveWorkbook.Name & _
"' jetzt gespeichert u. geschlossen werden?", vbQuestion + vbYesNo)
Set oWB = ActiveWorkbook
Workbooks.Open strNextFile
Else 'Datei offen
Set oWB = ActiveWorkbook
MsgBox "Datei mit diesen Namen ' " & sFileName & "' bereits offen!" & vbCr & "Diese wird jetzt aktiviert!", vbInformation
Workbooks(sFileName).Activate
End If
If intAntwort = vbYes Then
Application.EnableEvents = False
oWB.Close True
Application.EnableEvents = True
End If
Else
MsgBox "Excel- Datei '" & Format(DateMMJJ, "mmyy") & ".xls(m)' wurde nicht gefunden!", vbExclamation
End If
End Sub
Sub ButtenMenueRechteMaus(booErstellen As Boolean)
Dim NeuerButton(1) As CommandBarControl
On Error Resume Next
Set NeuerButton(0) = Application.CommandBars("cell").Controls(CaptionButtonZurueck)
Set NeuerButton(1) = Application.CommandBars("cell").Controls(CaptionButtonVor)
On Error GoTo 0
If booErstellen Then
If NeuerButton(0) Is Nothing Then
Set NeuerButton(0) = Application.CommandBars("cell").Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
With NeuerButton(0)
.Enabled = True
.FaceId = 41
.Caption = CaptionButtonZurueck 'Name im Menü
.OnAction = "'Suche_File ""-1""'" 'Name des Macros
End With
End If
NeuerButton(0).Visible = True
If NeuerButton(1) Is Nothing Then
Set NeuerButton(1) = Application.CommandBars("cell").Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
With NeuerButton(1)
.Enabled = True
.FaceId = 39
.Caption = CaptionButtonVor 'Name im Menü
.OnAction = "'Suche_File ""31""'" 'Name des Macros
End With
End If
NeuerButton(1).Visible = True
Else
If Not NeuerButton(0) Is Nothing Then NeuerButton(0).Visible = False
If Not NeuerButton(1) Is Nothing Then NeuerButton(1).Visible = False
End If
Erase NeuerButton
End Sub
Sub LoeschButton(ParamArray varButtonCaption() As Variant)
Dim varName
For Each varName In varButtonCaption
On Error Resume Next
Do While Err.Number = 0
Application.CommandBars("cell").Controls(varName).Delete
Loop
Err.Clear: On Error GoTo 0
Next varName
End Sub
kommt als Code in Modul2
Option Explicit
Function FindFile(ByVal sPath$, ParamArray ArrFilter() As Variant)
Dim fs As Object, strDir$, varFilter
Dim Ordner As Object, Unterordner As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set Ordner = fs.getfolder(sPath)
On Error GoTo ErrorZugriff:
FindFile = Find_File(fs, sPath, ArrFilter)
For Each Unterordner In Ordner.subfolders
FindFile = Find_File(fs, Unterordner.Path, ArrFilter)
If FindFile <> "" Then Exit Function
Next
For Each Unterordner In Ordner.subfolders
If FindFile <> "" Then Exit Function
FindFile Unterordner.Path
Next
ErrorZugriff:
Set fs = Nothing
End Function
Function Find_File(fs As Object, strPath$, ByVal ArrFilter)
Dim varFilter, strDir$
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
ChDrive Left$(strPath, 2)
ChDir strPath
For Each varFilter In ArrFilter
strDir = Dir$(strPath & varFilter)
If strDir <> "" Then
Find_File = strPath & strDir
End If
If Find_File <> "" Then Exit Function
Next varFilter
End Function
kommt als Code in Klasse1
Option Explicit
Public WithEvents ExcelWatch As Application
Private Sub ExcelWatch_WorkbookDeactivate(ByVal Wb As Workbook)
ButtenMenueRechteMaus False
End Sub
Private Sub ExcelWatch_WorkbookActivate(ByVal Wb As Workbook)
Dim sName$, nPos%
With Wb
nPos = InStrRev(.Name, ".")
If nPos > 4 Then _
sName = Mid$(.Name, nPos - 4, 4)
If sName Like "[0-1][0-9][0-9][0-9]" Then
ButtenMenueRechteMaus True
Else
ButtenMenueRechteMaus False
End If
End With
End Sub
Gruß Tino