Code problem.

[Juan]

Hi everybody,

I'm trying to run a macro from Excel which imports some data from MS Project.
I'm having some problems with the code and it’s getting me to lose
perspective.

I want the macro to look around and check whether the wanted .mpp is already
opened or not. In case it’s opened, the macro has to leave it opened at the
end. In case it wasn't opened, it will have to close it afterwards (only the
file in question).

I've got the impression that the more I work on the code, the more I'm
moving away from the right solution.

Lines 30 and/or 46 seem not to be working properly.
I’ve tried to solve it with Set XXX = GetObject( path ,
“MSProject.Applicationâ€), but unsuccessfully.


I post here the code and hope that someone can help me with it.
As I said, I may be trying to solve it wrongly. I'll accept any suggestions.
Thanks in advance,
Juan.

Private Sub CmdImportAP_Click()
Dim file As String
Dim path
Dim stabe As String
Dim i As Integer
Dim mpApp As MSProject.Application
Dim T As Task
Dim xlcell As Range
Dim Zelle As Range
Dim Spalte As Long
Dim X As String
Dim Y As String
Dim wanted As Variant
Dim objSheet As Worksheet
Dim p As Integer
Dim found As Boolean


1 path = Application.GetOpenFilename("Microsoft Project file
(*.mpp),*.mpp")
2 If path = False Then
3 MsgBox "no file chosen"
4 Exit Sub
5 Else
6 i = 1

7 Do
8 stabe = Left(Right(path, i), 1)
9 i = i + 1
10 file = stabe & file
11 Loop While stabe <> "\" And i < Len(path)
12 If Left(file, 1) = "\" Then
13 file = Right(file, Len(file) - 1)
14 End If
15 End If

16 Worksheets(4).Visible = True
17 Worksheets(4).Select
18 Application.ScreenUpdating = False

19 For Each Zelle In Worksheets(4).Range("A60:A560").Rows
20 If Zelle.Hidden = True Then
21 Zelle.Hidden = False
22 End If
23 Next

24 Application.ScreenUpdating = True

25 p = 0
26 found = False
27 For p = 0 To MSProject.Application.Projects.Count
28 If MSProject.Application.Projects.Item(p).Name = Datei Then
29 found = True
30 MSProject.Application.Projects.Item(p).Activate
31 End If
32 Next

33 If found = True Then
34 Set objSheet = Worksheets(4)
35 With objSheet
36 wanted = Range("RangeDatum").Value
37 Set xlcell = .Range("RangeLaufzeit").Find(what:=wanted, _
38 LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=True)
39 If Not xlcell Is Nothing Then
40 Spalte = xlcell.Column
41 Else
42 MsgBox "no matching date", vbInformation
43 Exit Sub
44 End If

45 Set xlcell = .Cells(62, Spalte)
46 For Each T In MSProject.Application.ActiveProject.Tasks
47 If Not T Is Nothing Then
48 If Not T.Summary Then
49 xlcell.Value = T.PercentComplete
50 xlcell.NumberFormat = "General\%"
51 Set xlcell = xlcell.Offset(1, 0)
52 End If
53 End If
54 Next T
55 Set xlcell = xlcell.Offset(-1, 0)
56 Y = xlcell.Address
57 X = Cells(61, Spalte).Address
58 .Range(X & ":" & Y).Select
59 End With


60 ElseIf found = False Then
61 Set mpApp = New MSProject.Application
62 mpApp.FileOpen path
63 mpApp.Visible = False

64 Set objSheet = Worksheets(4)
65 With objSheet
66 wanted = Range("RangeDatum").Value
67 Set xlcell = .Range("RangeLaufzeit").Find(what:=wanted, _
68 LookAt:=xlWhole, LookIn:=xlValues, MatchCase:=True)
69 If Not xlcell Is Nothing Then
70 Spalte = xlcell.Column
71 Else
72 MsgBox "no matching date", vbInformation
73 Exit Sub
74 End If

75 Set xlcell = .Cells(62, Spalte)
76 For Each T In mpApp.ActiveProject.Tasks
77 If Not T Is Nothing Then
78 If Not T.Summary Then
79 xlcell.Value = T.PercentComplete
80 xlcell.NumberFormat = "General\%"
81 Set xlcell = xlcell.Offset(1, 0)
82 End If
83 End If
84 Next T
85 Set xlcell = xlcell.Offset(-1, 0)
86 Y = xlcell.Address
87 X = Cells(61, Spalte).Address
88 .Range(X & ":" & Y).Select
89 End With
90 mpApp.FileClose pjDoNotSave
91 Set mpApp = Nothing
92 End If

93 Set objSheet = Nothing
94 Set xlcell = Nothing

95 AppActivate "Microsoft Excel"
96 Application.ActiveWorkbook.Worksheets(3).Activate
97 Range("CB20").Select
End Sub

 

[Guidho]

Seems like your problem is detecting if the MSProject application is running
or not and if the project is open.

Try this to detect if the application and project is open

Set mpApp = MSProject.Application

If mpApp.Visible = True Then
If mpApp.Projects.Count > 0 Then
For Each Proj In mpApp.Projects
If Proj.Name = Datei Then
found = True
Proj.Activate
End If
Next
End If
End If

Guidho

 

[Guidho]

I forgot one line. Of course you need to declare the variable Proj

Dim Proj as MSProject.Project

Guidho

 

[Juan]

Hi, Guidho

Thank you very much for your help.
It works perfectly!
Besides from your modification there was another mistake.
A quite silly one for my part.
With "If Proj.Name = Datei Then " i was trying to compare XXX with YYY.mpp,
which of course couldn't work.

Thanks again!

Juan

 

[Juan]

Hi, Guidho

I dont know what just happened.
The code worked perfectly yesterday, but know, without having changed any
line its returning one error:
"Run-time error "462": The remote-server-computer does not exist or is not
available"

The error points to the code line: "Set mpApp = MSProject.Application"
and is occurring only when the MS Project application is NOT running.

Do you know why is this happening?

Thanks in advance.

 

[Juan]

Hi again,

I think i can make it more precise.
The error is only appearing in the next case:
I execute the code with one project file opened=> it works.
Then I close the project file and I execute the code again, this time with
no project file opened and the project application closed => run-time error
'462' pointing to the "Set mpApp = MSProject.Application" codeline.
If I end the procedure and execute the code again, it works again. (?)

I'm posting the actual code. Would you be so kind to have a look at it?

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 Zelle 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 < Len(pfad)
If Left(Datei, 1) = "\" Then
Datei = Right(Datei, Len(Datei) - 1)
End If
Datei = Left(Datei, Len(Datei) - 4)
MsgBox Datei & vbCrLf & pfad, vbInformation

End If

Worksheets(4).Visible = True
Worksheets(4).Select
Application.ScreenUpdating = False
For Each Zelle In Worksheets(4).Range("A62:A561").Rows
If Zelle.Hidden = True Then
Zelle.Hidden = False
End If
Next

found = False
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

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

Application.ScreenUpdating = True

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

Thanks again.
Best regards,

Juan.