CT Witter
MrExcel MVP
- Joined
- Jul 7, 2002
- Messages
- 1,212
I have the below code to add access data to ms project. The issue is that I want to preserve dependency and outline tasks. Has anyone done this before?
Is there a way to tell ms project that certain tasks belong together?
Thanks!
CT
Is there a way to tell ms project that certain tasks belong together?
Thanks!
CT
Code:
Public Function basMSProject(OutputFolder As String)
' What:
' Author: LPJ Created: 9/1/99
' Last Revision: By: Ref:
On Error GoTo basMSProject_Err
'Me!ProgressBar.Visible = -1
'Me!lblOutput.Visible = -1
Dim ObjProj As MSProject.Application
Dim r As Recordset
Dim Ord As String
Dim i As Integer
Dim strMSProjPath As String
Dim myDb As Database
Dim msg, intRecs As Integer
Set myDb = CurrentDb
Set r = myDb.OpenRecordset("tbl1", dbOpenTable)
r.MoveLast
intRecs = r.RecordCount
'Me!ProgressBar.Value = 0
'Me!ProgressBar.Max = intRecs
r.MoveFirst
If r.EOF = -1 Then
r.Close
Exit Function
End If
DoCmd.Hourglass -1
Set ObjProj = CreateObject("MsProject.Application")
'If Dir(Me!OutputFolder, vbDirectory) = "" Then
'DoCmd.Beep
'MsgBox "Invalid output folder. Please check your spelling."
'GoTo basMSProject_Exit
'Else
strMSProjPath = OutputFolder
'End If
With ObjProj
.DisplayAlerts = False
.FileNew
Do Until r.EOF
'Me!ProgressBar.Value = Me!ProgressBar.Value + 1
.RowInsert
.SetTaskField "Name", r!Name
.SetTaskField "Start", Nz(r!Start, Date)
.SetTaskField "Duration", Nz(r!Duration, 1)
.SetTaskField "Resource Names", Nz("MXWorkPlan[100%]")
'.SetTaskField "ResourceNames", Nz(r!DeptID, "None")
'.SetTaskField "Notes", Nz(r!PMTitle, " ")
r.MoveNext
Loop
.FileSaveAs strMSProjPath & "MX_Work_Plan.mpp"
'Me!ProgressBar.Visible = 0
'Me!lblOutput.Visible = 0
If MsgBox("File output completed." & vbNewLine & "MS Project file: MX_Work_Plan.mpp" & vbNewLine & "can be found in " & strMSProjPath & "." & vbNewLine & vbNewLine & "Start MS Project to view output?", 36) = 6 Then
.Visible = True
.AppMaximize
Else
.Application.Quit
End If
End With
basMSProject_Exit:
On Error Resume Next
'Me!ProgressBar.Visible = 0
'Me!lblOutput.Visible = 0
Set ObjProj = Nothing
r.Close
DoCmd.Hourglass 0
Exit Function
basMSProject_Err:
DoCmd.Beep
If Err.Number = 429 Then
'App object doesn't exist
MsgBox "PREMO PAS cannot create the MS Project output. Verify MS Project is installed and working properly on this workstation.", 16, "basMSProject_Click"
Else
msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox msg, 16, "basMSProject_Click"
End If
Resume basMSProject_Exit
End Function