MSProject and VB


DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 2 of 2

Thread: MSProject and VB

  1. #1
    Mr. Anderson Guest

    MSProject and VB


    Hi,

    Does anyone know how to extract values from a Gantt chart in MSProject and
    manipulate those values in VB6?

    Regards,
    A

  2. #2
    Paul Guest

    Re: MSProject and VB


    "Mr. Anderson" <vedder@techie.com> wrote:
    >
    >Hi,
    >
    > Does anyone know how to extract values from a Gantt chart in MSProject

    and
    >manipulate those values in VB6?
    >
    >Regards,
    >A


    Hi

    You can reference MSProject with VB6

    'Private WithEvents mobjProject As prjMSProject.clsProject'


    Here is some sample code for MSProjects object model

    Option Explicit

    'Events
    Public Event GenError(strMessage As String, intSeverity As Integer)
    Public Event ProjectReady(strProjectPath As String, intUserID As Integer)

    'Our Microsoft Project Object
    Private mobjProject As MSProject.Application

    'And of course we require a connection
    Private mobjConnection As ADODB.Connection

    'Enum's
    Public Enum prjRec
    prjTimeLineInfo
    prjSytem
    prjMileStones
    prjResource
    End Enum

    Private Function mCreateMSProject() As Boolean

    On Error GoTo Err_Handler

    'First for speed we'll attempt to use what's there
    Set mobjProject = GetObject(, "MSProject.Application")

    Let mCreateMSProject = True

    Exit Function
    Err_Handler:

    'Ok it's not there so reset the error object
    Err.Clear

    On Error GoTo Err_Failure

    'And we'll instantiate a new object
    Set mobjProject = CreateObject("MSProject.Application")

    Let mCreateMSProject = True

    Exit Function
    Err_Failure:

    'Well we tried and Failed
    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to instantiate Project -" &
    Err.Description, vbExclamation)

    Let mCreateMSProject = False

    End Function

    Private Function mOpenConnection(ByVal vstrConnect As String) As Boolean

    'Set our Error Handler
    On Error GoTo Err_Handler

    'Set our new Connection
    Set mobjConnection = New ADODB.Connection

    'Open it
    Call mobjConnection.Open(vstrConnect)

    Let mOpenConnection = True

    Exit Function
    Err_Handler:

    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to open Database -" & Err.Description,
    vbExclamation)

    Let mOpenConnection = False

    End Function

    Private Function mOpenTemplate() As Boolean
    Dim strPath As String
    Dim rsRec As Recordset

    'Set error handler
    On Error GoTo Err_Handler

    'Ok retreive our Template file location
    Set rsRec = mOpenRecordset(Replace(mReturnSQL(prjSytem), "*P*", 3), adOpenForwardOnly)

    Let strPath = rsRec("xsysParamValue")

    mobjProject.FileOpen (strPath)

    Let mOpenTemplate = True

    Exit Function
    Err_Handler:

    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to open Template -" & Err.Description,
    vbExclamation)

    Let mOpenTemplate = False

    End Function

    Private Function mOpenRecordset(ByVal vstrSQL As String, ByVal vintType As
    CursorTypeEnum) As ADODB.Recordset
    Dim rsRec As Recordset

    'Set Error Handler
    On Error GoTo Err_Handler

    Set rsRec = New ADODB.Recordset

    'Well let's open a recordset
    Call rsRec.Open(vstrSQL, mobjConnection, vintType)

    Set mOpenRecordset = rsRec

    Set rsRec = Nothing

    Exit Function
    Err_Handler:

    'Big bad error
    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to open Record Set -" & Err.Description,
    vbExclamation)

    Call Err.Raise(Err.Number, "mOpenRecordset", Err.Description)

    End Function

    Private Function mReturnSQL(ByVal vintRec As prjRec) As String

    Select Case vintRec

    Case prjRec.prjMileStones

    Let mReturnSQL = "SELECT * FROM tttlmTimeLineMilestone WHERE
    ttmlTimelineID=*T*"

    Case prjRec.prjResource

    Let mReturnSQL = "SELECT * FROM tvrscResource WHERE ttmlTimelineID=*T*"

    Case prjRec.prjSytem

    Let mReturnSQL = "SELECT xsysParamValue FROM txsysSysParam WHERE
    xsysParamid=*P*"

    Case prjRec.prjTimeLineInfo

    Let mReturnSQL = "SELECT * FROM tttmlTimeline WHERE ttmlTimeLineID=*T*"

    Case Else

    Call Err.Raise(999, "mReturnSQL", "Invalid SQL Requested")

    End Select

    End Function

    Private Function mSaveFile(ByRef rstrPath, _
    ByVal vlngTimeLineID As Long) As Boolean
    'Save the Template we have open
    'The Path will be returned in rstrPath
    Dim strFileName As String
    Dim strSQL As String

    'Set Error handler
    On Error GoTo Err_Handler

    'Need to retreive the Project Name
    Let strFileName = mOpenRecordset(Replace(mReturnSQL(prjTimeLineInfo),
    "*T*", vlngTimeLineID), adOpenForwardOnly)("ttmlName")

    'Now save it with this Name
    mobjProject.FileSaveAs (rstrPath & strFileName)

    Let mSaveFile = True

    Exit Function
    Err_Handler:

    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to Save Project -" & Err.Description,
    vbExclamation)

    Let mSaveFile = False

    End Function

    Private Function mPopDocProperties(ByVal vlngTimeLineID As Long) As Boolean
    'This is where we populate document properties
    Dim strSQL As String
    Dim rsRecTL As Recordset
    Dim rsRecSys As Recordset
    Dim objDocProp As DocumentProperty

    'Set error handler
    On Error GoTo Err_Handler

    'Set SQL
    Let strSQL = Replace(mReturnSQL(prjTimeLineInfo), "*T*", vlngTimeLineID)

    'Open a recordset for TL
    Set rsRecTL = mOpenRecordset(strSQL, adOpenForwardOnly)

    '----TIME LINE PROPERTIES

    'Try and add property TL_ID
    Call mobjProject.ActiveProject.AddProp("TL_ID", msoPropertyTypeNumber,
    vlngTimeLineID)

    'Project Name
    Call mobjProject.ActiveProject.AddProp("TL_NAME", msoPropertyTypeString,
    rsRecTL("ttmlName"))

    'User
    Call mobjProject.ActiveProject.AddProp("TL_USER", msoPropertyTypeNumber,
    rsRecTL("xusrUserID"))

    'Date Created
    Call mobjProject.ActiveProject.AddProp("TL_DATECREATED", msoPropertyTypeDate,
    Date)

    'Project Start
    Call mobjProject.ActiveProject.AddProp("TL_START", msoPropertyTypeDate,
    rsRecTL("ttmlStartDate"))

    'Project Description
    Call mobjProject.ActiveProject.AddProp("TL_DESC", msoPropertyTypeString,
    rsRecTL("ttmlDesc"))

    '----System Properties (Paths etc)

    'Set SQL
    Let strSQL = Replace(mReturnSQL(prjSytem), "*P*", 4)

    'Open System Table Rec
    Set rsRecSys = mOpenRecordset(strSQL, adOpenForwardOnly)

    'Server Location
    Call mobjProject.ActiveProject.AddProp("TL_SERVER", msoPropertyTypeString,
    rsRecSys("xsysParamValue"))

    'Set SQL
    Let strSQL = Replace(mReturnSQL(prjSytem), "*P*", 5)

    'Open System Table Rec
    Set rsRecSys = mOpenRecordset(strSQL, adOpenForwardOnly)

    'DLL Name
    Call mobjProject.ActiveProject.AddProp("TL_DLL", msoPropertyTypeString,
    rsRecSys("xsysParamValue"))

    ' End With

    Let mPopDocProperties = True

    Exit_Function:

    Set rsRecTL = Nothing
    Set rsRecSys = Nothing

    Exit Function
    Err_Handler:

    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to Set Project properties -"
    & Err.Description, vbExclamation)

    Let mPopDocProperties = False

    Resume Exit_Function

    End Function

    Private Function mSyncMilestones(ByVal vlngTimeLineID As Long) As Boolean
    Dim objTask As Task
    Dim strSQL As String
    Dim rsRec As Recordset

    'Set Error Handler
    On Error GoTo Err_Handler

    'Set SQL
    Let strSQL = Replace(mReturnSQL(prjMileStones), "*T*", vlngTimeLineID)

    'Open Recordset
    Set rsRec = mOpenRecordset(strSQL, adOpenForwardOnly)

    'Loop Through and Add tasks
    Do While Not (rsRec.EOF)

    'Generates New Task
    Set objTask = mobjProject.ActiveProject.Tasks.Add(rsRec("ttlmTitle").Value)

    With objTask
    .Start = rsRec("ttlmStartDate").Value
    .Finish = rsRec("ttlmEndDate").Value
    .Text1 = rsRec("ttlmTimeLineMilestoneID").Value
    End With

    rsRec.MoveNext

    Loop

    Let mSyncMilestones = True

    Exit_Function:

    Set rsRec = Nothing

    Exit Function
    Err_Handler:

    'Set Error Msg
    RaiseEvent GenError("Error Occured Unable to Sync Project milestones
    -" & Err.Description, vbExclamation)

    Let mSyncMilestones = False

    Resume Exit_Function

    End Function

    Private Function mPopResources(ByVal vlngTimeLineID As Long) As Boolean
    Dim strSQL As String
    Dim rsRec As Recordset

    'Set Error Handler
    On Error GoTo Err_Handler

    'Set SQL to retreive Resources
    Let strSQL = Replace(mReturnSQL(prjResource), "*T*", vlngTimeLineID)

    Set rsRec = mobjConnection.Execute(strSQL)

    While Not rsRec.EOF

    With mobjProject.ActiveProject

    Call .AddResource(rsRec("xusrNAme"), rsRec("xjbtRate"))

    End With

    rsRec.MoveNext

    Wend

    Exit Function
    Err_Handler:

    Err.Raise Err.Number, "mPopResources", Err.Description

    End Function


    Public Function GenerateProject(ByVal vstrConnect As String, _
    ByVal vlngTimeLineID As Long) As Boolean
    Dim strSQL As String
    Dim rsRec As Recordset

    Dim strPath As String 'This will be the path of the completed Project
    File
    Dim intUserID As Integer 'Store user to be emailed

    'Set basic error handler
    On Error GoTo Err_Handler

    strPath = "C:\"

    'Ok first we need project
    If mCreateMSProject Then

    'Open Our Connection
    If mOpenConnection(vstrConnect) Then

    'Open the Template file
    If mOpenTemplate Then

    'Save as TimeLine
    Call mSaveFile(strPath, vlngTimeLineID)

    'Now we set the document Properties
    Call mPopDocProperties(vlngTimeLineID)

    'Check For existing Milestones
    Call mSyncMilestones(vlngTimeLineID)

    'Populate Resources
    Call mPopResources(vlngTimeLineID)

    'Set Our Project to Active
    Call mobjProject.ActiveProject.EditProp("IN_USE", 1)

    'Save as TimeLine
    Call mSaveFile(strPath, vlngTimeLineID)

    'Email to User
    RaiseEvent ProjectReady(strPath, intUserID)

    'Open Template If
    End If

    'Connection IF
    End If

    'Create Project IF
    End If

    mobjProject.Quit

    Exit Function
    Err_Handler:

    'Set Error Msg
    RaiseEvent GenError("Error Occured " & Err.Description, vbExclamation)

    mobjProject.Quit

    'Bail out
    Let GenerateProject = False

    End Function


    Regards Paul








Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center