"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
|
без бутылки не разберешься!!! 
