AW: Workbooks.Open öffnet Datei nicht
18.12.2014 06:56:33
Marcus
Ich habe den Wink mit dem Zaunpfahl verstanden. Der Code ist mittlerweile nur sehr umfangreich. Ich werde euch die interessanten Stellen hier rein stellen.
Aufruf der Userform durch einen DropDown; alles in einem Tabellenblatt und funktioniert auch einwandfrei (der Code der Userform kommt unten):
Option Explicit
Dim Jahr
Private Sub Worksheet_Change(ByVal Target As Range)
' Spalte T: Berichte ändern
If Target.Column = 22 Then
If Target.Cells = "(1) Bericht anlegen" Then
Call CreateReport(Target.Row)
End If
End If
End Sub
Sub CreateReport(RowNo As Integer)
Dim ProjectName
ProjectName = GetProjectName(RowNo)
Unload UF_CreateReport 'auszuwertende Berichte wählen
With UF_CreateReport
.Tag = Jahr & "." & ProjectName
.Show
End With
Call Berichte_sortieren(RowNo, RowNo)
ActiveSheet.Cells(RowNo, "V").Select
ActiveSheet.Cells(RowNo, "V") = ""
End Sub
Aufruf über das Kontextmenü; die Userform wird aufgerufen aber Workbooks.Open funktioniert nicht:
Das steht im Tabellenblatt
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Jahr = Right(ActiveSheet.Cells(1, 1), 4)
If Not Application.Intersect(Target, Range("W:AF")) Is Nothing Then
Call AddToCellMenu(Target.Row, Target.Column, Jahr)
End If
End Sub
Das steht in Modul 2:
Sub AddToCellMenu(Row, Column, Jahr)
Dim NVHContextMenu As CommandBar
Dim MySubMenu As CommandBarControl
Dim Flag
' Reset the controls first to avoid duplicates.
Call ResetNVHCellMenu
'Set NVHContextMenu to the Cell menu
Set NVHContextMenu = Application.CommandBars("Cell")
'Kontextmenüs passend zum jeweiligen Bericht anzeigen
With NVHContextMenu.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) _
.OnAction = "'" & ThisWorkbook.Name & "'!" & "BerichtAnlegen(" & Row & "," & _
Column & "," & Jahr & ")"
.FaceId = 71
.Caption = "Bericht anlegen"
End With
End Sub
Sub ResetNVHCellMenu()
CommandBars("Cell").Reset
End Sub
Sub BerichtAnlegen(R, C, Jahr)
Dim ProjectName
ProjectName = GetProjectName(R)
Unload UF_CreateReport 'auszuwertende Berichte wählen
With UF_CreateReport
.Tag = Jahr & "." & ProjectName
.Show
End With
End Sub
Public Function GetProjectDirectory(RowNo)
Dim MeasurementDir, ProjectName As String
MeasurementDir = "J:\Messdaten\NVH\" & Year(Now) & "\"
ProjectName = GetProjectName(RowNo)
GetProjectDirectory = MeasurementDir & ProjectName 'Projektpfad
End Function
Public Function GetProjectName(RowNo) As String
Dim Name
Name = Range("A" & RowNo).Value & "_" & Range("D" & RowNo).Value & "_" & Range("E" & RowNo). _
Value & "_" & Range("F" & RowNo).Value 'Projektname
GetProjectName = Sonderzeichen(Name) 'konformen Namen übergeben
End Function
Public Function Sonderzeichen(Buffer)
Buffer = Replace(Buffer, " ", " ")
Buffer = Replace(Buffer, " ", " ")
Buffer = Replace(Buffer, " ", "_")
'Buffer = Replace(Buffer, "ä", "ae")
'Buffer = Replace(Buffer, "ö", "oe")
'Buffer = Replace(Buffer, "ü", "ue")
'Buffer = Replace(Buffer, "ß", "ss")
Buffer = Replace(Buffer, "\", "_")
Buffer = Replace(Buffer, "/", "_")
Buffer = Replace(Buffer, "*", ".")
Buffer = Replace(Buffer, "?", ".")
Buffer = Replace(Buffer, """", "_")
Buffer = Replace(Buffer, "", "_")
Buffer = Replace(Buffer, "|", "-")
'Buffer = Replace(Buffer, ",", "_")
Sonderzeichen = Buffer
End Function
So und nun die wesentlichen Stellen der Userform, die wie gesagt in beiden Fällen genutzt wird. Es geht an sich um diese Unterfunktion, die in der Userform steht.
Function GetFPNr(NVHNr, Sprache, Schreib As Boolean)
Application.ScreenUpdating = False
Dim wb As Workbook, geoeffnet As Boolean
Dim Datei, Dateipfad, RowNo, sEnd, I
geoeffnet = False
'Pfad und Dateiname der Belegungsliste aus "Globale VBA-Variablen"
Datei = FP(2)
Dateipfad = FP(1)
'feststellen, ob eine der offenen Mappen wie die Belegungsliste heißt
For Each wb In Application.Workbooks
If wb.Name = Datei Then geoeffnet = True
Next wb
'Wenn Datei von anderem User geöffnet
If Iffileisopen(Dateipfad & Datei) And geoeffnet = False Then
Mldg = "Die Datei " & Datei & " ist bereits von einem anderen User geöffnet." & _
vbCrLf & "Es wird eine provisorische FP-Nummer vergeben." & vbCrLf & "Bitte ergänzen Sie diese später manuell in der Belegungsliste und ändern Sie den Dateinamen."
Stil = vbOKOnly + vbInformation + vbDefaultButton1
Tit = "Belegungsliste von anderem User geöffnet"
Answer = MsgBox(Mldg, Stil, Tit)
GetFPNr = "xxx"
Else 'Wenn Datei noch nicht offen, dann frei Nummer suchen und belegen
'entsprechend reagieren
If geoeffnet Then
Application.Workbooks(Datei).Activate
Else
Application.Workbooks.Open Filename:=Dateipfad & Datei, UpdateLinks:=0
End If
With Sheets(CStr(Jahr))
For I = 5 To Rows.Count
If .Cells(I, "B") = "" And .Cells(I, "C") = "" And .Cells(I, "D") = "" And . _
Cells(I, "E") = "" And .Cells(I, "F") = "" Then
RowNo = I
Exit For
End If
Next
'Liste füllen
If Schreib Then
If MultiPageCrR.Value = 0 Then
If .Cells(RowNo, 1) = "" Then .Range("A" & RowNo).Value = "FP_" & _
Format(Right(Jahr, 2), "00") & "_" & RowNo - 4 'Daten eintragen
.Range("B" & RowNo).Value = TBTitel.Value
.Range("C" & RowNo).Value = TBUntertitel.Value
.Range("D" & RowNo).Value = TBKat_Ku.Value
.Range("E" & RowNo).Value = TBProjekt.Value
.Range("F" & RowNo).Value = TBBearbeiter.Value
.Range("G" & RowNo).Value = TBBemerkung.Value
.Range("H" & RowNo).Value = TBDatum.Value
Else
If .Cells(RowNo, 1) = "" Then .Range("A" & RowNo).Value = "FP_" & _
Format(Right(Jahr, 2), "00") & "_" & RowNo - 4 'Daten eintragen
MsgBox "FP6.7"
.Range("B" & RowNo).Value = TBTitel2.Value
.Range("C" & RowNo).Value = TBUntertitel2.Value
.Range("D" & RowNo).Value = TBKat_Ku2.Value
.Range("E" & RowNo).Value = TBProjekt2.Value
.Range("F" & RowNo).Value = TBBearbeiter2.Value
.Range("G" & RowNo).Value = TBBemerkung2.Value
.Range("H" & RowNo).Value = TBDatum2.Value
End If
Workbooks(Datei).Save
Workbooks(Datei).Close
Else
Workbooks(Datei).Close SaveChanges:=False
End If
End With
'Nummer ausgeben
GetFPNr = RowNo - 4
End If
Application.ScreenUpdating = True
End Function