T
Tony
I have the database designed by someone with the module which should export
data from the database to Microsoft Project. My problem is that it does not
work the same way on different systems, results are not the same. On some
systems filtering of the data does not work, on others exporting stops if the
date value is more than one year in the future. Could someone look into the
code of this module and tell me where are the problems coming from. Code
below:
*************************************
Attribute VB_Name = "modReportToProject"
Option Compare Database
Option Explicit
Sub ReportToProject(Optional lngGroupID As Long, Optional lngSubGroupID As
Long)
Dim cnn As Object
Dim rsExport As Object, rsExportRes As Object
Dim pj As Object, apj As Object
Dim intCounter As Integer, lngTotalRecords As Long
Dim strProjectName As String, strPath As String
Dim strCurrentAsset As String, intCreateproject As Integer
Dim strGroupName As String
Dim blnExists As Boolean
On Error GoTo Err_ReportToProject
'set variables
Set cnn = CurrentProject.Connection
Set rsExport = CreateObject("ADODB.Recordset")
Set rsExportRes = CreateObject("ADODB.Recordset")
If lngGroupID = 0 Then
rsExport.Open "SELECT * FROM qryExportToProject", cnn, 1
rsExportRes.Open "SELECT * FROM qryExportResources", cnn, 1
Else
If lngSubGroupID = 0 Then
rsExport.Open "SELECT * FROM qryExportToProject WHERE
lngGeneralGroupsID = " & lngGroupID, cnn, 1
rsExportRes.Open "SELECT * FROM qryExportResources WHERE
[tblGeneralGroups].[lngGeneralGroupsID] = " & lngGroupID, cnn, 1
Else
rsExport.Open "SELECT * FROM qryExportToProject WHERE
lngAssetGroupID = " & lngSubGroupID, cnn, 1
rsExportRes.Open "SELECT * FROM qryExportResources WHERE
lngAssetGroupID = " & lngSubGroupID, cnn, 1
End If
End If
Set pj = CreateObject("msProject.Application")
strPath = CurrentProject.Path & "\"
strProjectName = "hire"
strProjectName & """ in the path " & strPath & ". " & _
"The project will replace the existing project and take a few
minutes. " & Chr(10) & _
"Do you wish to create the project now?", _
buttons:=vbYesNo + vbInformation, _
Title:=APP_TITLE)
With pj
strGroupName = rsExportRes!strGeneralGroup
If lngGroupID = 0 Then
For Each apj In .Projects
If apj.Name = strProjectName & ".mpp" Then
apj.Activate
.docClose
End If
Next
Else
For Each apj In .Projects
If apj.Name = strProjectName & "-" & strGroupName & ".mpp"
Then
apj.Activate
.docClose
End If
Next
End If
.Visible = True
.Calculation 0 'pjManual
.FileOpen Name:=strPath & strProjectName & ".mpt"
.ViewApply Name:="Resource &Sheet"
'create the resource table
intCounter = 1
rsExportRes.MoveLast
rsExportRes.MoveFirst
lngTotalRecords = rsExportRes.RecordCount
Do While Not rsExportRes.EOF
.SetResourceField "Name", rsExportRes!AssetName.Value, , ,
intCounter
.SetResourceField "Initials", rsExportRes!lngAssetCode.Value, ,
, intCounter
.SetResourceField "Code", rsExportRes!lngAssetCode.Value, , ,
intCounter
.SetResourceField "Group", rsExportRes!strGeneralGroup.Value, ,
, intCounter
rsExportRes.MoveNext
Forms!Switchboard.Option3.StatusBarText = "Creating Project:
Loading Resources " & Format(intCounter / lngTotalRecords, "0%") & "
complete!"
intCounter = intCounter + 1
Loop
rsExportRes.Close
'for each asset in the database
.ViewApply "&Gantt Chart" 'Name:="&Gantt Chart"
strCurrentAsset = ""
intCounter = 1
rsExport.MoveLast
lngTotalRecords = rsExport.RecordCount
rsExport.MoveFirst
Do While Not rsExport.EOF
If strCurrentAsset <> rsExport!strName.Value Then
.SetTaskField "Name", rsExport!strName.Value, , , intCounter
.SetTaskField "Resource Names", rsExport!strName.Value, , ,
intCounter
If .Projects(strProjectName).Tasks(intCounter).OutlineLevel
= 2 Then
.Projects(strProjectName).Tasks(intCounter).OutlineOutdent
End If
strCurrentAsset = rsExport!strName.Value
intCounter = intCounter + 1
lngTotalRecords = lngTotalRecords + 1
End If
If Not IsNull(rsExport!strJobName.Value) Then
If rsExport!dteHireStart.Value <
..Projects(strProjectName).ProjectStart Then
.Projects(strProjectName).ProjectStart =
rsExport!dteHireStart.Value
End If
.SetTaskField "Start", rsExport!dteHireStart.Value, , ,
intCounter
.SetTaskField "Name", rsExport!strJobName.Value, , ,
intCounter
.SetTaskField "Duration", rsExport!dteHireFinish.Value -
rsExport!dteHireStart.Value, , , intCounter
If Not IsNull(rsExport!intServiceDuration.Value) Then
.SetTaskField "Finish10", rsExport!dteHireFinish.Value +
rsExport!intServiceDuration.Value, , , intCounter
Else
.SetTaskField "Finish10", rsExport!dteHireFinish.Value,
, , intCounter
End If
If Not IsNull(rsExport!WShopLoc.Value) Then .SetTaskField
"Text10", rsExport!WShopLoc.Value, , , intCounter
If rsExport!StatusID = 2 Then 'confirmed
.SetTaskField "Flag2", 1, , , intCounter
ElseIf rsExport!StatusID = 1 Then 'potential
.SetTaskField "Flag1", 1, , , intCounter
ElseIf rsExport!StatusID = 3 Then 'go line
.SetTaskField "Flag3", 1, , , intCounter
End If
.SetTaskField "Rollup", "Yes", , , intCounter
.SetTaskField "Text1", rsExport!strCustomerName.Value, , ,
intCounter
.SetTaskField "Resource Names", rsExport!strName.Value, , ,
intCounter
If .Projects(strProjectName).Tasks(intCounter).OutlineLevel
= 1 Then
.Projects(strProjectName).Tasks(intCounter).OutlineIndent
End If
intCounter = intCounter + 1
End If
rsExport.MoveNext
Forms!Switchboard.Option3.StatusBarText = "Creating Project:
Loading Tasks " & Format(intCounter / lngTotalRecords, "0%") & " complete!"
Loop
rsExport.Close
.Alerts False
.Calculation -1 'pjAutomatic
.EditGoTo 1, Format(Now(), "d/mm/yyyy hh:mm")
If lngGroupID = 0 Then
.FileSaveAs Name:=strPath & strProjectName
Else
.FileSaveAs Name:=strPath & strProjectName & "-" & strGroupName
End If
End With
Forms!Switchboard.Option3.StatusBarText = ""
Exit_ReportToProject:
Set rsExport = Nothing
Set rsExportRes = Nothing
cnn.Close
Set cnn = Nothing
Set pj = Nothing
Exit Sub
Err_ReportToProject:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_ReportToProject
End Sub
*************************************
Thanks for help.
data from the database to Microsoft Project. My problem is that it does not
work the same way on different systems, results are not the same. On some
systems filtering of the data does not work, on others exporting stops if the
date value is more than one year in the future. Could someone look into the
code of this module and tell me where are the problems coming from. Code
below:
*************************************
Attribute VB_Name = "modReportToProject"
Option Compare Database
Option Explicit
Sub ReportToProject(Optional lngGroupID As Long, Optional lngSubGroupID As
Long)
Dim cnn As Object
Dim rsExport As Object, rsExportRes As Object
Dim pj As Object, apj As Object
Dim intCounter As Integer, lngTotalRecords As Long
Dim strProjectName As String, strPath As String
Dim strCurrentAsset As String, intCreateproject As Integer
Dim strGroupName As String
Dim blnExists As Boolean
On Error GoTo Err_ReportToProject
'set variables
Set cnn = CurrentProject.Connection
Set rsExport = CreateObject("ADODB.Recordset")
Set rsExportRes = CreateObject("ADODB.Recordset")
If lngGroupID = 0 Then
rsExport.Open "SELECT * FROM qryExportToProject", cnn, 1
rsExportRes.Open "SELECT * FROM qryExportResources", cnn, 1
Else
If lngSubGroupID = 0 Then
rsExport.Open "SELECT * FROM qryExportToProject WHERE
lngGeneralGroupsID = " & lngGroupID, cnn, 1
rsExportRes.Open "SELECT * FROM qryExportResources WHERE
[tblGeneralGroups].[lngGeneralGroupsID] = " & lngGroupID, cnn, 1
Else
rsExport.Open "SELECT * FROM qryExportToProject WHERE
lngAssetGroupID = " & lngSubGroupID, cnn, 1
rsExportRes.Open "SELECT * FROM qryExportResources WHERE
lngAssetGroupID = " & lngSubGroupID, cnn, 1
End If
End If
Set pj = CreateObject("msProject.Application")
strPath = CurrentProject.Path & "\"
strProjectName = "hire"
strProjectName & """ in the path " & strPath & ". " & _
"The project will replace the existing project and take a few
minutes. " & Chr(10) & _
"Do you wish to create the project now?", _
buttons:=vbYesNo + vbInformation, _
Title:=APP_TITLE)
With pj
strGroupName = rsExportRes!strGeneralGroup
If lngGroupID = 0 Then
For Each apj In .Projects
If apj.Name = strProjectName & ".mpp" Then
apj.Activate
.docClose
End If
Next
Else
For Each apj In .Projects
If apj.Name = strProjectName & "-" & strGroupName & ".mpp"
Then
apj.Activate
.docClose
End If
Next
End If
.Visible = True
.Calculation 0 'pjManual
.FileOpen Name:=strPath & strProjectName & ".mpt"
.ViewApply Name:="Resource &Sheet"
'create the resource table
intCounter = 1
rsExportRes.MoveLast
rsExportRes.MoveFirst
lngTotalRecords = rsExportRes.RecordCount
Do While Not rsExportRes.EOF
.SetResourceField "Name", rsExportRes!AssetName.Value, , ,
intCounter
.SetResourceField "Initials", rsExportRes!lngAssetCode.Value, ,
, intCounter
.SetResourceField "Code", rsExportRes!lngAssetCode.Value, , ,
intCounter
.SetResourceField "Group", rsExportRes!strGeneralGroup.Value, ,
, intCounter
rsExportRes.MoveNext
Forms!Switchboard.Option3.StatusBarText = "Creating Project:
Loading Resources " & Format(intCounter / lngTotalRecords, "0%") & "
complete!"
intCounter = intCounter + 1
Loop
rsExportRes.Close
'for each asset in the database
.ViewApply "&Gantt Chart" 'Name:="&Gantt Chart"
strCurrentAsset = ""
intCounter = 1
rsExport.MoveLast
lngTotalRecords = rsExport.RecordCount
rsExport.MoveFirst
Do While Not rsExport.EOF
If strCurrentAsset <> rsExport!strName.Value Then
.SetTaskField "Name", rsExport!strName.Value, , , intCounter
.SetTaskField "Resource Names", rsExport!strName.Value, , ,
intCounter
If .Projects(strProjectName).Tasks(intCounter).OutlineLevel
= 2 Then
.Projects(strProjectName).Tasks(intCounter).OutlineOutdent
End If
strCurrentAsset = rsExport!strName.Value
intCounter = intCounter + 1
lngTotalRecords = lngTotalRecords + 1
End If
If Not IsNull(rsExport!strJobName.Value) Then
If rsExport!dteHireStart.Value <
..Projects(strProjectName).ProjectStart Then
.Projects(strProjectName).ProjectStart =
rsExport!dteHireStart.Value
End If
.SetTaskField "Start", rsExport!dteHireStart.Value, , ,
intCounter
.SetTaskField "Name", rsExport!strJobName.Value, , ,
intCounter
.SetTaskField "Duration", rsExport!dteHireFinish.Value -
rsExport!dteHireStart.Value, , , intCounter
If Not IsNull(rsExport!intServiceDuration.Value) Then
.SetTaskField "Finish10", rsExport!dteHireFinish.Value +
rsExport!intServiceDuration.Value, , , intCounter
Else
.SetTaskField "Finish10", rsExport!dteHireFinish.Value,
, , intCounter
End If
If Not IsNull(rsExport!WShopLoc.Value) Then .SetTaskField
"Text10", rsExport!WShopLoc.Value, , , intCounter
If rsExport!StatusID = 2 Then 'confirmed
.SetTaskField "Flag2", 1, , , intCounter
ElseIf rsExport!StatusID = 1 Then 'potential
.SetTaskField "Flag1", 1, , , intCounter
ElseIf rsExport!StatusID = 3 Then 'go line
.SetTaskField "Flag3", 1, , , intCounter
End If
.SetTaskField "Rollup", "Yes", , , intCounter
.SetTaskField "Text1", rsExport!strCustomerName.Value, , ,
intCounter
.SetTaskField "Resource Names", rsExport!strName.Value, , ,
intCounter
If .Projects(strProjectName).Tasks(intCounter).OutlineLevel
= 1 Then
.Projects(strProjectName).Tasks(intCounter).OutlineIndent
End If
intCounter = intCounter + 1
End If
rsExport.MoveNext
Forms!Switchboard.Option3.StatusBarText = "Creating Project:
Loading Tasks " & Format(intCounter / lngTotalRecords, "0%") & " complete!"
Loop
rsExport.Close
.Alerts False
.Calculation -1 'pjAutomatic
.EditGoTo 1, Format(Now(), "d/mm/yyyy hh:mm")
If lngGroupID = 0 Then
.FileSaveAs Name:=strPath & strProjectName
Else
.FileSaveAs Name:=strPath & strProjectName & "-" & strGroupName
End If
End With
Forms!Switchboard.Option3.StatusBarText = ""
Exit_ReportToProject:
Set rsExport = Nothing
Set rsExportRes = Nothing
cnn.Close
Set cnn = Nothing
Set pj = Nothing
Exit Sub
Err_ReportToProject:
MsgBox Err.Number & ": " & Err.Description
Resume Exit_ReportToProject
End Sub
*************************************
Thanks for help.