POST Time Entry

The following VBA code for submitting a Time Entry to Teamwork Projects was kindly shared by Michael Sorber.


Sub Save_To_Teamwork()
'
' Save a time entry to Teamwork
'

    ' Declare Variables based on example
    Dim xmlhttp As Object
    Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
    Dim apiurl, myurl, xmlMsg, user, Password As String
    
    ' Declare time entry items for teamwork
    Dim task_id, description, person_id, entry_date, start_time, hours, minutes, isbillable, tags As String
    Dim my_time As Date
    
    ' Declare Variables for Looping
    Dim cell As Range
    Const quote = """"
    Dim count As Integer
    count = 0
    
    ' Credentials
    user = "" 'Place API Key Here
    Password = "not_used" 'Teamwork doesnt use password with API
    
       
    ' Loop through cells selected and open in URL
    For Each cell In Selection
        task_id = Cells(cell.Row, 14).Value
        description = Cells(cell.Row, 10).Value
        person_id = Cells(cell.Row, 16).Value
        entry_date = Format(Cells(cell.Row, 1).Value, "yyyymmdd")
        start_time = Format(Cells(cell.Row, 2).Value, "hh:mm")
        hours = Cells(cell.Row, 5).Value
        minutes = Cells(cell.Row, 6).Value
        isbillable = Cells(cell.Row, 12).Value
        tags = Cells(cell.Row, 11).Value
    
        
        ' Set Billable to Binary for XML Message
        If isbillable = "Yes" Then
            isbillable = 1
        Else
            isbillable = 0
        End If
        
        ' Set myurl for Task
        myurl = "https://yourcompany.teamwork.com/tasks/" & task_id & "/time_entries.xml"

        ' Open connection
        xmlhttp.Open "POST", myurl, False
        xmlhttp.setRequestHeader "Accept", "application/xml"
        xmlhttp.setRequestHeader "Content-Type", "application/xml"
        xmlhttp.setRequestHeader "Authorization", "Basic " + Base64Encode(user + ":" + Password)
            
            
        ' Build message to send
        xmlMsg = "<request><time-entry>"
        xmlMsg = xmlMsg & "<description>" & description & "</description>"
        xmlMsg = xmlMsg & "<person-id>" & person_id & "</person-id>"
        xmlMsg = xmlMsg & "<date>" & entry_date & "</date>"
        xmlMsg = xmlMsg & "<time>" & quote & start_time & quote & "</time>"
        xmlMsg = xmlMsg & "<hours>" & hours & "</hours>"
        xmlMsg = xmlMsg & "<minutes>" & minutes & "</minutes>"
        xmlMsg = xmlMsg & "<isbillable>" & isbillable & "</isbillable>"
        xmlMsg = xmlMsg & "<tags>" & tags & "</tags>"
        xmlMsg = xmlMsg & "</time-entry></request>"
                
        ' Send Message
        If Cells(cell.Row, 17) = "Added" Then
            'skip
        Else
            'add to Teamwork
            xmlhttp.Send xmlMsg
            
            If xmlhttp.Status = "403" Then
                MsgBox "Row wasn't added. Check that you are on the project"
            ElseIf xmlhttp.Status = "201" Then
                ' Flag row as Added
                Cells(cell.Row, 17).Value = "Added"
                count = count + 1
            Else
                MsgBox "Row wasn't added. Following are Debug messages for review"
                MsgBox (xmlhttp.Status) 'DEBUG - Output Status
                MsgBox xmlMsg 'DEBUG - Output xmlMsg
            End If
        
        End If
           
    Next cell
    
    MsgBox count & " time entries were added to Teamwork."
    
End Sub

Function Base64Encode(sText)
    Dim oXML, oNode
    Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
    Set oNode = oXML.CreateElement("base64")
    oNode.DataType = "bin.base64"
    oNode.nodeTypedValue = Stream_StringToBinary(sText)
    Base64Encode = oNode.Text
    Set oNode = Nothing
    Set oXML = Nothing
End Function



'Stream_StringToBinary Function
'2003 Antonin Foller, http://www.motobit.com
'Text - string parameter To convert To binary data

Function Stream_StringToBinary(Text)
  Const adTypeText = 2
  Const adTypeBinary = 1

  'Create Stream object
  Dim BinaryStream 'As New Stream
  Set BinaryStream = CreateObject("ADODB.Stream")

  'Specify stream type - we want To save text/string data.
  BinaryStream.Type = adTypeText

  'Specify charset For the source text (unicode) data.
  BinaryStream.Charset = "us-ascii"

  'Open the stream And write text/string data To the object
  BinaryStream.Open
  BinaryStream.WriteText Text

  'Change stream type To binary
  BinaryStream.Position = 0
  BinaryStream.Type = adTypeBinary

  'Ignore first two bytes - sign of
  BinaryStream.Position = 0

  'Open the stream And get binary data from the object
  Stream_StringToBinary = BinaryStream.Read

  Set BinaryStream = Nothing
End Function



'Stream_BinaryToString Function
'2003 Antonin Foller, http://www.motobit.com
'Binary - VT_UI1 | VT_ARRAY data To convert To a string

Function Stream_BinaryToString(Binary)
  Const adTypeText = 2
  Const adTypeBinary = 1

  'Create Stream object
  Dim BinaryStream 'As New Stream
  Set BinaryStream = CreateObject("ADODB.Stream")

  'Specify stream type - we want To save text/string data.
  BinaryStream.Type = adTypeBinary

  'Open the stream And write text/string data To the object
  BinaryStream.Open
  BinaryStream.Write Binary

  'Change stream type To binary
  BinaryStream.Position = 0
  BinaryStream.Type = adTypeText

  'Specify charset For the source text (unicode) data.
  BinaryStream.Charset = "us-ascii"

  'Open the stream And get binary data from the object
  Stream_BinaryToString = BinaryStream.ReadText
  Set BinaryStream = Nothing
End Function