Word中的Task导出到Starteam

工作中需要在Word中编辑任务，由Starteam发布任务。所以编写了一个VBA程序，将Word中的任务导出到Starteam
首先在VBA中引用StarTeam SDK，程序如下
' Sample code showing how to connect to a
' StarTeam Server using Microsoft Visual Basic.
Sub StarTeam()
    Dim strAddress As String
    Dim nPort As Long
    Dim strUser As String
    Dim strPassword As String
    
    strAddress = "StarTeamserver"
    nPort = 49201
    strUser = "user"
    strPassword = "password"
    
    ' Create a new StarTeam Server Factory.
    Dim Factory As New StServerFactory
    
    ' Use factory to create a new initialized Server object.
    Dim Server As StServer
    Set Server = Factory.Create(strAddress, nPort)
    
    ' Establish a connection to the Server.
    ' This is optional - logOn() connects if necessary.
    Server.Connect
    
    ' LogOn as a specific user.
    Server.logOn strUser, strPassword
    
    ' Use the Server object to enumerate
    ' Projects and Views, etc.
   
    Dim project As StProject
    Set project = FindProject(Server, "Project")
   
    Dim view As StView
    'For Each V In project.Views
    Set view = project.DefaultView
   
    Dim folder As StFolder
    Set folder = view.RootFolder
    Call WordToStarTeam(Server, folder)
        
    ' Disconnect when finished.
    Server.Disconnect
End Sub

' Enumerates the projects available on the given
' server, looking for the one with the given name.
Public Function FindProject(Server As StServer, strName As String) As StProject
 
    'Set FindProject = Null
    For Each P In Server.Projects
        If P.Name = strName Then
            Set FindProject = P
            Exit For
        End If
    Next
    
End Function

Sub WordToStarTeam(Server As StServer, folder As StFolder)
    Dim table As table
    Dim celTable As Cell
    Dim rngTable As Range
    Dim startDate, finishDate As Date
   
    Dim task As StTask
    Dim taskFactory As New StTaskFactory
    Dim user As StUser
    Dim userID As Long
    Dim taskName As String
   
    Set table = ActiveDocument.Tables(1)
    Set celTable = table.Cell(2, 2)
    Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
            End:=celTable.Range.End - 1)
    startDate = rngTable.Text
   
    Set celTable = table.Cell(2, 4)
    Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
            End:=celTable.Range.End - 1)
    finishDate = rngTable.Text
   
    For i = 4 To table.Rows.Count
        Set celTable = table.Cell(i, 2)
        Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
            End:=celTable.Range.End - 1)
        taskName = rngTable.Text
        If rngTable.Italic = 0 Then '斜体表示没有任务(返回-1)
            Set celTable = table.Cell(i, 4)
            Set rngTable = ActiveDocument.Range(Start:=celTable.Range.Start, _
                End:=celTable.Range.End - 1)
            Set task = taskFactory.Create(folder)
            task.Name = taskName
           
            Dim bFound As Boolean
            bFound = False
            For Each user In Server.ActiveUsers
                If user.Name = Trim(rngTable.Text) Then
                    userID = user.ID
                    bFound = True
                End If
            Next
            If Not bFound Then
                Debug.Print Trim(rngTable.Text) + " not found!"
                Exit For
            End If
           
            task.Responsibility = userID
            task.Status = 1 '0: Pending, 1:Ready to Start, 2:In Progress, 3:Finished, 4, Closed
            task.EstimatedStart = startDate
            task.EstimatedFinish = finishDate
            task.Duration = 40
            task.Update
        End If
    Next
   
End Sub