I try to export some data from Excel to MS Project with VBA. The first time it works fine. When I close only the MS Project file but leave the MS Project application open, then second time it works as well. If I close the MS Project application then I get the error "Error 462 The remote server machine does not exist or is unavailable"
All the time I leave the Excel application open!
The second time it stops at line which I have marked red. If I change this line in pjapp.Selectbeginning, then it stops at the next line. I don't understand it.
I use Excel / MS Project Office 2002 pro and Windows 2000 (client)
Please help.
Thanks in advance.
Nico
VBA:
[vba]
Function ExportToMSProject(ByVal stOpdrNr)
Dim pjapp As Object
Dim Temp As Long, Names As String
Dim strValue, strStartDate, strEndDate, sETP5_nr, Msg, Style, Title As String
Dim sNaamIndiener, sPurNr, sS_Bon_ATB, sAfdAanvrNr, sProjectNr, sAanvrNr As String
Dim t As Task
Dim i As Integer
Dim SheetWizard As New SheetWizard
Dim wshSheet As Worksheet
Dim iLoc, ilocStart, iLocEnd, iAant, iRijNr As Integer
Dim sFindChar, sAanvrOpdrNr As String
Set wshSheet = ActiveSheet
Set SheetWizard.SheetMap = wshSheet
If (Openfile("M:\ETP\ETP5\02. Planning\MS Planning\", "HB-standaardfile.mpp", False)) Then
Set pjapp = CreateObject("MSProject.application")
If pjapp Is Nothing Then
MsgBox "Project is not installed"
End
End If
'now that we have an application we make it visible
pjapp.Visible = True
'pjApp.Application.FileOpen "My Project.mpp"
'If Not (Openfile("M:\ETP\ETP5\02. Planning\MS Planning\", "HB-standaardfile.mpp", False)) Then
pjapp.Application.FileOpen "HB-standaardfile.mpp"
'GoTo Exit_Here
'End If
iAant = 0
iLoc = 0
ilocStart = 1
sFindChar = ","
Do
iLoc = InStr(iLoc + 1, stOpdrNr, sFindChar)
'Indien nog een komma in de string is gevonden dan is iLocSlash <> 0
'Indien geen komma is gevonden ==> einde string bereikt.
If (iLoc <> 0) Then
iLocEnd = iLoc - 1
Else
iLocEnd = Len(stOpdrNr)
End If
sAanvrOpdrNr = Trim(General.ReadPartString(stOpdrNr, ilocStart, iLocEnd))
ilocStart = iLoc + 1
'Haal het rij nr. op voor van het opdracht nr.
iRijNr = General.FindOpdrnr(sAanvrOpdrNr)
If (iRijNr <> 0) Then
AppActivate "Microsoft Excel"
Worksheets("openstaande orders").Activate
'Naam indiener = task description!
sNaamIndiener = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "Naam_indiener"))
'PO nummer
sPurNr = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "PurNummer"))
's-Bon/ATB nr
sS_Bon_ATB = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "S_Bon_ATB"))
'Kostenplaats = afd. nummer
sAfdAanvrNr = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "AfdAanvrNr"))
'Projectnummer
sProjectNr = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "ProjectNr"))
'Aanvraag opdrachtnr.
sAanvrNr = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "AanvrNr"))
'ETP-5 nr = B nr
sETP5_nr = Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "ETP5_Nr"))
If (sNaamIndiener = "") Then
MsgBox "De naam van de indiener is niet ingevuld. Dit veld is verplicht!" & _
Chr(13) & Chr(10) & "Er kan geen export van Excel naar MSProject gemaakt worden."
GoTo Exit_Here
ElseIf (sPurNr = "" Or sS_Bon_ATB = "") Then
MsgBox "Het Pur nr. en/of het S-Bon/ATB nr. is niet ingevuld. E?n van deze twee velden moet ingevuld zijn!" & _
Chr(13) & Chr(10) & "Er kan geen export van Excel naar MSProject gemaakt worden."
GoTo Exit_Here
ElseIf (sAfdAanvrNr = "") Then
MsgBox "Het afdeling nr. aanvr. is niet ingevuld. Dit veld is verplicht!" & _
Chr(13) & Chr(10) & "Er kan geen export van Excel naar MSProject gemaakt worden."
GoTo Exit_Here
ElseIf (sProjectNr = "") Then
MsgBox "Het Project nr. is niet ingevuld. Dit veld is verplicht!" & _
Chr(13) & Chr(10) & "Er kan geen export van Excel naar MSProject gemaakt worden."
GoTo Exit_Here
ElseIf (sAanvrNr = "") Then
MsgBox "Het Aanvr nr. is niet ingevuld. Dit veld is verplicht!" & _
Chr(13) & Chr(10) & "Er kan geen export van Excel naar MSProject gemaakt worden."
GoTo Exit_Here
ElseIf (sETP5_nr <> "") Then
Msg = "Er is voor de opdracht " & sAanvrNr & " al een ETP-5 nr. ingevuld. Wilt u verder gaan?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "ETP-5 nr." ' Define title.
'Help = "DEMO.HLP" ' Define Help file.
'Ctxt = 1000 ' Define topic
' context.
' Display message.
Dim Response
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then ' User chose Yes.
GoTo Exit_Here
End If
End If
AppActivate "Microsoft Project"
'Application.Windows("HB-standaardfile.mpp").Activate
'ActiveProject.Visible = True
'pjapp.Visible = True
SelectBeginning
sETP5_nr = ActiveProject.Tasks(1).text1
'ActiveProject.tasks.Application.OutlineShowTasks
SelectRow
EditCopy
'EditInsert
EditPaste
ActiveProject.Tasks.Application.OutlineHideSubTasks
SelectBeginning
'SelectCellDown (1)
'ActiveProject.tasks.Application.OutlineShowTasks
'sETP5Next_nr = StripString(sETP5_nr, 1)
ActiveProject.Tasks(1).text1 = StripString(sETP5_nr, 1) 'sETP5Next_nr
For Temp = 2 To ActiveProject.Tasks.Count
'MsgBox Temp & " --- " & ActiveProject.tasks(Temp).Name
If (ActiveProject.Tasks(Temp).text1 = sETP5_nr) Then
'MsgBox ActiveProject.tasks(Temp).Name & " **** " & ActiveProject.tasks(Temp).Text1
'Task name = naam indiener
ActiveProject.Tasks(Temp).Name = sNaamIndiener 'Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "Naam_indiener"))
'PO nummer
ActiveProject.Tasks(Temp).text2 = sPurNr 'Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "PurNummer"))
's-Bon/ATB nr
ActiveProject.Tasks(Temp).text3 = sS_Bon_ATB 'Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "S_Bon_ATB"))
'Kostenplaats = afd. nummer
ActiveProject.Tasks(Temp).text6 = sAfdAanvrNr 'Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "AfdAanvrNr"))
'Projectnummer
ActiveProject.Tasks(Temp).text7 = sProjectNr 'Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "ProjectNr"))
'Aanvraag opdrachtnr.
ActiveProject.Tasks(Temp).text8 = sAanvrNr 'Trim(SheetWizard.Get_Hor_Range_Waarde(iRijNr, "AanvrNr"))
Exit For
End If
Next Temp
End If
Loop Until (iLoc = 0)
Else
MsgBox "Het bestand HB-standaardfile.mpp is al geopend"
GoTo Exit_Here
End If
pjapp.FileClose pjSave
'pjapp.Application.Close
Exit_Here:
Set wshSheet = Nothing
Set SheetWizard.SheetMap = Nothing
Set pjapp = Nothing
End Function
[/vba]
Reply With Quote