rrenis
03-12-2009, 07:04 AM
Hi all :hi:
I have the following code that has been adapted from some code that was kindly posted by KeithRoberts. It runs from MS Project but I've posted here as I'm sure the problems lie with what is occuring with Excel.
1) Ideally I'd like to be able to change the way the task dates are added to the row within excel but I'm not sure how to do it :(. The reason for this is that I think the global Excel.Range is causing a problem with the code. This is because an instance of Excel is left running in my process list after the code is run (sometimes, but not always) which seems to effect how reliable the export is. ometimes for instance no data is written to the excel file.
2) Also, I've noticed that on some PC's I get an ActiveX error when the code trys to determine if an instance of Excel is running - this part of the code was added to try and counter to the problems of Excel not shutting down properly from previous attempts of running the code.
3) Finally, I also sometimes receive a server response error when trying to open the data.xls file but I have no idea why? :dunno
If anyone has any ideas on how to improve the way the data is added to excel I'd be very grateful, especially if there is a way to remove the global Excel.Range : pray2: (as I'm sure this would solve point 2 as I could remove the check to see if Excel is running).
' References - Microsoft Scripting Runtime AND Microsoft Excel 11.0 Object Library
Option Explicit
Sub ExportTasks()
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
ResumeExportTasks:
Dim RemoteServerError As Integer
Application.ScreenUpdating = False
Dim fso As New FileSystemObject
Dim xlApp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim xlWorkSheet As Object
Dim tsk As Task
Dim Tsks As Tasks
Dim TaskNumber As Integer
Dim sRef As String
Dim NewApp As String
Dim myHeader As String
Dim MYTerminate As String
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim intError As Integer
On Error Resume Next
' the following checks to see whether excel is running, and if not creates an excel application
Set xlApp = GetObject(, "Excel.Application") ' THIS SOMETIMES CREATES AN ACTIVEX ERROR
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
NewApp = True
Else
NewApp = False
End If
On Error GoTo 0
xlApp.Visible = False
xlApp.ScreenUpdating = False
Set xlbook = xlApp.Workbooks.Add
Set xlsheet = xlbook.Worksheets.Add
xlApp.Calculation = xlManual
xlApp.CalculateBeforeSave = False
xlApp.DisplayAlerts = False
On Error GoTo ErrorMessage
Dim Rng As Range
Dim SheetName As String
Dim toDel As Range
MY_Progress.Show ' USERFORM - this just loads up to show that the code is running - not essential if anyone thinks this could cause a problem
DoEvents
sRef = Left(ActiveProject.Name, 5) ' get the project reference from the Project filename
SheetName = "MY_Data"
Workbooks.Open FileName:="C:\Data.xls", UpdateLinks:=3 ' THIS SOMETIMES CAUSES A SERVER RESPONSE ERROR
Dim sht As Object
Sheets(SheetName).Select
Set Rng = ActiveWorkbook.Worksheets(SheetName).Range("A:A")
' the following find the existing reference in the excel spreadsheet and if found deletes it so that the new dates can be written
FindRef:
Set toDel = Rng.Find(sRef)
If toDel Is Nothing Then GoTo PasteData Else
Rng.Parent.Rows(toDel.Row).Delete
GoTo FindRef
PasteData:
Range("A65536").End(xlUp).Offset(1, 0).Select ' find the last cell in column A to insert the new data
Set xlRow = xlApp.ActiveCell
' the following is specific to exporting the MS Project task dates to excel
TaskNumber = 0
Set Tsks = ActiveProject.Tasks
For Each tsk In Tsks
If Not tsk Is Nothing Then
NextTaskStart:
Set xlCol = xlRow.Offset(0, TaskNumber)
If TaskNumber = 0 Then xlCol = sRef
rgt 1
If TaskNumber > ActiveProject.NumberOfTasks + ActiveProject.NumberOfTasks + 10 Then GoTo TaskError
TaskNumber = TaskNumber + 1 ' used to move the excel offset value to the next column to correspond with the tasknumber
myHeader = Range("A1").Offset(0, TaskNumber).Value
If myHeader <> tsk.Name & " Start" Then GoTo NextTaskStart ' compare task name with column header so that correct dates are added against corresponding task _
names in the columns (this is here as some of the headers may not be present as task names in MS Project
xlCol = tsk.Start
rgt 1
NextTaskFinish:
If TaskNumber > ActiveProject.NumberOfTasks + ActiveProject.NumberOfTasks + 10 Then GoTo TaskError
TaskNumber = TaskNumber + 1
myHeader = Range("A1").Offset(0, TaskNumber).Value
If myHeader <> tsk.Name & " Finish" Then GoTo NextTaskFinish ' as above but for task finish, not task start
Set xlCol = xlRow.Offset(0, TaskNumber)
xlCol = tsk.Finish
End If
Next tsk
ActiveWorkbook.Close savechanges:=True
If NewApp = True Then
MYTerminate = "Excel.exe" ' the following code attempts to close any instances of excel left running is a new object has been created
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & MYTerminate & "'")
If objList.Count = 0 Then GoTo MYExit Else
For Each objProcess In objList
intError = objProcess.Terminate
Next
MYExit:
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Else
xlApp.Quit
End If
Set xlApp = Nothing
Set fso = Nothing
Unload MY_Progress
Application.ScreenUpdating = True
MsgBox "Data for project " & sRef & " has been successfully exported. ", , "Data Export"
GoTo MacroExit
Exit Sub
TaskError:
MsgBox "The following Task name cannot be found in the Database: " & vbNewLine & _
" " & vbNewLine & tsk.Name & vbNewLine & " ", 0, "Faliure"
MacroExit:
If NewApp = True Then
MYTerminate = "Excel.exe"
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & MYTerminate & "'")
If objList.Count = 0 Then GoTo MYExit Else
For Each objProcess In objList
intError = objProcess.Terminate
Next
MYExit:
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Else
xlApp.Quit
End If
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
If RemoteServerError = 1 Then GoTo ResumeExportTasks
Exit Sub
ErrorMessage:
RemoteServerError = RemoteServerError + 1
If RemoteServerError = 1 Then GoTo MacroExit
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Macro Name: ExportTasks" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MacroExit
End Sub
Sub dwn(i As Integer)
Set xlRow = xlRow.Offset(i, 0)
End Sub
Sub rgt(i As Integer)
Set xlCol = xlCol.Offset(0, i)
End Sub
Thanks for looking :thumb
Cheers,
rrenis
I have the following code that has been adapted from some code that was kindly posted by KeithRoberts. It runs from MS Project but I've posted here as I'm sure the problems lie with what is occuring with Excel.
1) Ideally I'd like to be able to change the way the task dates are added to the row within excel but I'm not sure how to do it :(. The reason for this is that I think the global Excel.Range is causing a problem with the code. This is because an instance of Excel is left running in my process list after the code is run (sometimes, but not always) which seems to effect how reliable the export is. ometimes for instance no data is written to the excel file.
2) Also, I've noticed that on some PC's I get an ActiveX error when the code trys to determine if an instance of Excel is running - this part of the code was added to try and counter to the problems of Excel not shutting down properly from previous attempts of running the code.
3) Finally, I also sometimes receive a server response error when trying to open the data.xls file but I have no idea why? :dunno
If anyone has any ideas on how to improve the way the data is added to excel I'd be very grateful, especially if there is a way to remove the global Excel.Range : pray2: (as I'm sure this would solve point 2 as I could remove the check to see if Excel is running).
' References - Microsoft Scripting Runtime AND Microsoft Excel 11.0 Object Library
Option Explicit
Sub ExportTasks()
Dim xlRow As Excel.Range
Dim xlCol As Excel.Range
ResumeExportTasks:
Dim RemoteServerError As Integer
Application.ScreenUpdating = False
Dim fso As New FileSystemObject
Dim xlApp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim xlWorkSheet As Object
Dim tsk As Task
Dim Tsks As Tasks
Dim TaskNumber As Integer
Dim sRef As String
Dim NewApp As String
Dim myHeader As String
Dim MYTerminate As String
Dim objWMIcimv2 As Object
Dim objProcess As Object
Dim objList As Object
Dim intError As Integer
On Error Resume Next
' the following checks to see whether excel is running, and if not creates an excel application
Set xlApp = GetObject(, "Excel.Application") ' THIS SOMETIMES CREATES AN ACTIVEX ERROR
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
NewApp = True
Else
NewApp = False
End If
On Error GoTo 0
xlApp.Visible = False
xlApp.ScreenUpdating = False
Set xlbook = xlApp.Workbooks.Add
Set xlsheet = xlbook.Worksheets.Add
xlApp.Calculation = xlManual
xlApp.CalculateBeforeSave = False
xlApp.DisplayAlerts = False
On Error GoTo ErrorMessage
Dim Rng As Range
Dim SheetName As String
Dim toDel As Range
MY_Progress.Show ' USERFORM - this just loads up to show that the code is running - not essential if anyone thinks this could cause a problem
DoEvents
sRef = Left(ActiveProject.Name, 5) ' get the project reference from the Project filename
SheetName = "MY_Data"
Workbooks.Open FileName:="C:\Data.xls", UpdateLinks:=3 ' THIS SOMETIMES CAUSES A SERVER RESPONSE ERROR
Dim sht As Object
Sheets(SheetName).Select
Set Rng = ActiveWorkbook.Worksheets(SheetName).Range("A:A")
' the following find the existing reference in the excel spreadsheet and if found deletes it so that the new dates can be written
FindRef:
Set toDel = Rng.Find(sRef)
If toDel Is Nothing Then GoTo PasteData Else
Rng.Parent.Rows(toDel.Row).Delete
GoTo FindRef
PasteData:
Range("A65536").End(xlUp).Offset(1, 0).Select ' find the last cell in column A to insert the new data
Set xlRow = xlApp.ActiveCell
' the following is specific to exporting the MS Project task dates to excel
TaskNumber = 0
Set Tsks = ActiveProject.Tasks
For Each tsk In Tsks
If Not tsk Is Nothing Then
NextTaskStart:
Set xlCol = xlRow.Offset(0, TaskNumber)
If TaskNumber = 0 Then xlCol = sRef
rgt 1
If TaskNumber > ActiveProject.NumberOfTasks + ActiveProject.NumberOfTasks + 10 Then GoTo TaskError
TaskNumber = TaskNumber + 1 ' used to move the excel offset value to the next column to correspond with the tasknumber
myHeader = Range("A1").Offset(0, TaskNumber).Value
If myHeader <> tsk.Name & " Start" Then GoTo NextTaskStart ' compare task name with column header so that correct dates are added against corresponding task _
names in the columns (this is here as some of the headers may not be present as task names in MS Project
xlCol = tsk.Start
rgt 1
NextTaskFinish:
If TaskNumber > ActiveProject.NumberOfTasks + ActiveProject.NumberOfTasks + 10 Then GoTo TaskError
TaskNumber = TaskNumber + 1
myHeader = Range("A1").Offset(0, TaskNumber).Value
If myHeader <> tsk.Name & " Finish" Then GoTo NextTaskFinish ' as above but for task finish, not task start
Set xlCol = xlRow.Offset(0, TaskNumber)
xlCol = tsk.Finish
End If
Next tsk
ActiveWorkbook.Close savechanges:=True
If NewApp = True Then
MYTerminate = "Excel.exe" ' the following code attempts to close any instances of excel left running is a new object has been created
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & MYTerminate & "'")
If objList.Count = 0 Then GoTo MYExit Else
For Each objProcess In objList
intError = objProcess.Terminate
Next
MYExit:
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Else
xlApp.Quit
End If
Set xlApp = Nothing
Set fso = Nothing
Unload MY_Progress
Application.ScreenUpdating = True
MsgBox "Data for project " & sRef & " has been successfully exported. ", , "Data Export"
GoTo MacroExit
Exit Sub
TaskError:
MsgBox "The following Task name cannot be found in the Database: " & vbNewLine & _
" " & vbNewLine & tsk.Name & vbNewLine & " ", 0, "Faliure"
MacroExit:
If NewApp = True Then
MYTerminate = "Excel.exe"
Set objWMIcimv2 = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objList = objWMIcimv2.ExecQuery("select * from win32_process where name='" & MYTerminate & "'")
If objList.Count = 0 Then GoTo MYExit Else
For Each objProcess In objList
intError = objProcess.Terminate
Next
MYExit:
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Else
xlApp.Quit
End If
Set objWMIcimv2 = Nothing
Set objList = Nothing
Set objProcess = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
If RemoteServerError = 1 Then GoTo ResumeExportTasks
Exit Sub
ErrorMessage:
RemoteServerError = RemoteServerError + 1
If RemoteServerError = 1 Then GoTo MacroExit
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Macro Name: ExportTasks" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MacroExit
End Sub
Sub dwn(i As Integer)
Set xlRow = xlRow.Offset(i, 0)
End Sub
Sub rgt(i As Integer)
Set xlCol = xlCol.Offset(0, i)
End Sub
Thanks for looking :thumb
Cheers,
rrenis