Code Problem
24.04.2008 16:29:00
Juan
Der folgende Code dient mir dazu, einen Datenaustausch mit Ms Project zu machen.
Erstens wird die .mpp Datei ausgewählt. Anschließend wird festgestellt ob die Datei schon offen ist oder nicht, um sie am Ende der Prozedur demnach zu schließen oder offen zu lassen.
Der Code funktioniert einigermassen gut, bis zu einem kleinen Punkt, das ich jetzt erkläre:
- Ich führe den Code mit der .mpp Datei offen. Funktioniert. Daten werden rausgenommen und .mpp Datei bleibt am Ende offen.
- Jetzt schliesse ich die .mpp Datei, und führe den Code wieder aus, ohne offene .mpp Datei im Hintergrund, also MS Project Applikation läuft nicht. Und nun taucht der Fehler auf, und zwar: "Laufzeitfehler '462': Der remote-server-computer existiert nicht oder steht nicht zur Verfügung" . Debuggen: die Zeile Set mpAPP = MSProject.Application wird gezeigt.
- Wenn ich stattdessen Beenden drücke und den Code wieder ausführe, funktioniert es halt wieder, das heiß, die .mpp Datei wird aufgemacht und am Ende wieder geschlossen. (?) Es sieht so aus als ob es in diesem Fall nötig wäre den Code 2mal laufen zu lassen.
Ich habe keine Ahnung was da los ist. Ich hoffe dass jmd mir dabei helfen kann.
Ich bedanke mich für jeden Hinweis im Voraus.
Beste Grüße,
Juan.
Anbei der Code:
Private Sub CmdImportAP_Click()
Dim Datei As String
Dim pfad
Dim stabe As String
Dim i As Integer
Dim mpApp As MSProject.Application
Dim proj As MSProject.Project
Dim T As Task
Dim xlcell As Range
Dim Spalte As Long
Dim X As String
Dim Y As String
Dim Gesucht As Variant
Dim objSheet As Worksheet
Dim found As Boolean
pfad = Application.GetOpenFilename("Microsoft Project Datei (*.mpp), *.mpp")
If pfad = False Then
MsgBox "Keine Datei wurde ausgewählt."
Exit Sub
Else
i = 1
Do
stabe = Left(Right(pfad, i), 1)
i = i + 1
Datei = stabe & Datei
Loop While stabe "\" And i Set mpApp = MSProject.Application
If mpApp.Visible = True Then
MsgBox "visible", vbInformation
If mpApp.Projects.Count > 0 Then
MsgBox "> 0", vbInformation
For Each proj In mpApp.Projects
MsgBox proj.Name, vbInformation
If proj.Name = Datei Then
found = True
proj.Activate
MsgBox "activated", vbInformation
End If
Next
End If
End If
Application.ScreenUpdating = True
If found = True Then
MsgBox "works...", vbInformation
Set objSheet = Worksheets(4)
With objSheet
Gesucht = Range("RangeDatum").Value
Set xlcell = .Range("RangeLaufzeit").Find(what:=Gesucht, _
LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not xlcell Is Nothing Then
Spalte = xlcell.Column
Else
MsgBox "Es wurde kein passendes Datum gefunden.", vbInformation
Exit Sub
End If
Set xlcell = .Cells(63, Spalte) 'Set xlCell =
xlCell.Offset(1, 0)
For Each T In mpApp.ActiveProject.Tasks
If Not T Is Nothing Then
If Not T.Summary Then
xlcell.Value = T.PercentComplete
xlcell.NumberFormat = "General\%"
Set xlcell = xlcell.Offset(1, 0)
End If
End If
Next T
Set xlcell = xlcell.Offset(-1, 0)
Y = xlcell.Address
X = Cells(63, Spalte).Address
.Range(X & ":" & Y).Select
End With
ElseIf found = False Then
Set mpApp = New MSProject.Application
mpApp.FileOpen pfad
mpApp.Visible = False
Set objSheet = Worksheets(4)
With objSheet
Gesucht = Range("RangeDatum").Value
Set xlcell = .Range("RangeLaufzeit").Find(what:=Gesucht, _
LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=True)
If Not xlcell Is Nothing Then
Spalte = xlcell.Column
Else
MsgBox "Es wurde kein passendes Datum gefunden.", vbInformation
Exit Sub
End If
Set xlcell = .Cells(63, Spalte) 'Set xlCell =
xlCell.Offset(1, 0)
For Each T In mpApp.ActiveProject.Tasks
If Not T Is Nothing Then
If Not T.Summary Then
xlcell.Value = T.PercentComplete
xlcell.NumberFormat = "General\%"
Set xlcell = xlcell.Offset(1, 0)
End If
End If
Next T
Set xlcell = xlcell.Offset(-1, 0)
Y = xlcell.Address
X = Cells(63, Spalte).Address
.Range(X & ":" & Y).Select
End With
mpApp.FileClose pjDoNotSave
End If
' mpApp.Quit
Set mpApp = Nothing
Set objSheet = Nothing
Set xlcell = Nothing
AppActivate "Microsoft Excel"
Application.ActiveWorkbook.Worksheets(3).Activate
Range("CB21").Select
'Sheets(3).Range("CB20").Select
End Sub