I currently have an Excel spreadsheet that tracks high-level milestones that are linked against JIRA issues. I have a VBA script that executes the following URL and it parses the XML to extract dates, actual work, remaining work, status, resolution, etc.:
Dim MyRequest As New WinHttpRequest Dim resultXml As MSXML2.DOMDocument, resultNode As IXMLDOMElement MyRequest.Open "GET", _ "https://my.jira.location/si/jira.issueviews:issue-xml/" & jiraIssue & "/" & jiraIssue & ".xml" MyRequest.setRequestHeader "Authorization", "Basic " & EncodeBase64(userName & ":" & password) MyRequest.setRequestHeader "Content-Type", "application/xml" MyRequest.Send Set resultXml = New MSXML2.DOMDocument resultXml.LoadXML MyRequest.ResponseText
This works great! I also have Agile RapidBoard Sprints listed in this spreadsheet. Is there a way to programmatically query JIRA (using VBA like above) to get the start date, end date, original work estimate, current work estimate, and actual work completed associated with a sprint?
Well, I found a way to do it using JSON but not XML. I have been successful at getting the start date and end date by parsing the "sprintreport" JSON results. I parsed the current work estimate and actual work from the "scopechangeburndownchart" JSON results. The latter wasn't very straightforward as it appears that the scopechangeburndownchart returns work logs for items outside the dates of the sprint as well as inside the sprint dates; so I had to do some additional filtering. The estimated work remaining lines up 100% with what the Sprint Burndown UI Chart says. The time spent is close but doesn't match 100%; I havent' figured out why just yet.
Here is the code for those who may be interested. It uses code from the VBA JSON project. I have not cleaned it up yet but will do so as time allows.
JiraSprintContents Class Module:
Public name As String Public startDate As String Public endDate As String Public status As String Public sumTimeSpent As String Public sumTimeRemaining As String Public isValid As Boolean ' Set this to true if the JIRA finds the sprint, false otherwise Public errorString As String
Private Function extractSprintContents(jiraUrl As String, userName As String, password As String, ByVal rapidBoardId As String, ByVal sprintId As String) As JiraSprintContents Dim JiraService As New MSXML2.XMLHTTP60 Dim JiraAuth As New MSXML2.XMLHTTP60 Dim sprintDetailsResult As String Dim sprintBurndownResult As String Dim MyRequest As New WinHttpRequest Dim resultXml As MSXML2.DOMDocument, resultNode As IXMLDOMElement Dim sprintDetails As Dictionary Dim burndownDetails As Dictionary Dim issueDetailsCache As New Dictionary Dim tempDate() As String Dim tempJsonIssue As Dictionary Dim tempIssueWorkDetails As JiraIssueWorkDetails Dim tempIssueId As String Dim sprintStartEpochMilliseconds As Double Dim sprintEndEpochMilliseconds As Double Dim tempChangeDate As Double Dim tempTimeRemaining As Double Dim tempTimeSpent As Double tempTimeRemaining = 0# tempTimeSpent = 0# ' Query JIRA for sprint details MyRequest.Open "GET", _ jiraUrl & "/rest/greenhopper/1.0/rapid/charts/sprintreport?rapidViewId=" & rapidBoardId & "&sprintId=" & sprintId MyRequest.setRequestHeader "Authorization", "Basic " & EncodeBase64(userName & ":" & password) MyRequest.setRequestHeader "Content-Type", "application/json" MyRequest.Send sprintDetailsResult = MyRequest.ResponseText Set extractSprintContents = New JiraSprintContents Set sprintDetails = parse(sprintDetailsResult) If (sprintDetails.Exists("sprint")) Then extractSprintContents.isValid = True ' Get start date of sprint If (sprintDetails.Item("sprint").Exists("startDate")) Then tempDate = Split(sprintDetails.Item("sprint").Item("startDate"), " ") extractSprintContents.startDate = tempDate(0) End If ' Get end date of sprint If (sprintDetails.Item("sprint").Exists("endDate")) Then tempDate = Split(sprintDetails.Item("sprint").Item("endDate"), " ") extractSprintContents.endDate = tempDate(0) End If ' Get sprint name If (sprintDetails.Item("sprint").Exists("name")) Then extractSprintContents.name = sprintDetails.Item("sprint").Item("name") End If ' Get sprint status If (sprintDetails.Item("sprint").Exists("state")) Then Select Case sprintDetails.Item("sprint").Item("state") Case "CLOSED" extractSprintContents.status = "Closed" Case "ACTIVE" extractSprintContents.status = "Active" Case "FUTURE" extractSprintContents.status = "Future" Case Else extractSprintContents.status = sprintDetails.Item("sprint").Item("state") End Select End If ' Convert start and end dates to Epoch in milliseconds (used later for ' calculated time spent in the sprint ' sprintStartEpochMilliseconds If Len(extractSprintContents.startDate) > 6 Then sprintStartEpochMilliseconds = DateDiff("s", #1/1/1970#, extractSprintContents.startDate) * 1000 Else sprintStartEpochMilliseconds = DateDiff("s", #1/1/1970#, Now()) * 1000 End If If Len(extractSprintContents.endDate) > 6 Then sprintEndEpochMilliseconds = DateDiff("s", #1/1/1970#, extractSprintContents.endDate) * 1000 Else sprintEndEpochMilliseconds = DateDiff("s", #1/1/1970#, Now()) * 1000 End If ' Parse the scope change burndown chart to sum the work performed in this sprint ' as well as sum the remaining work at the end of the sprint. Set MyRequest = New WinHttpRequest MyRequest.Open "GET", _ jiraUrl & "/rest/greenhopper/1.0/rapid/charts/scopechangeburndownchart?rapidViewId=" & rapidBoardId & "&sprintId=" & sprintId MyRequest.setRequestHeader "Authorization", "Basic " & EncodeBase64(userName & ":" & password) MyRequest.setRequestHeader "Content-Type", "application/json" MyRequest.Send sprintBurndownResult = MyRequest.ResponseText Set burndownDetails = parse(sprintBurndownResult) If burndownDetails.Exists("changes") Then ' Loop through details, create a structure for each issue. ' 1. Add work completed to the issue structure ' 2. Store the remaining estimate to the issue structure For Each strKey In burndownDetails.Item("changes").keys For index = 1 To burndownDetails.Item("changes").Item(strKey).Count Set tempJsonIssue = burndownDetails.Item("changes").Item(strKey).Item(index) If tempJsonIssue.Exists("timeC") Then tempIssueId = tempJsonIssue.Item("key") ' Create JiraIssueWorkDetails or pull from cache If issueDetailsCache.Exists(tempIssueId) Then Set tempIssueWorkDetails = issueDetailsCache.Item(tempIssueId) Else Set tempIssueWorkDetails = New JiraIssueWorkDetails tempIssueWorkDetails.issueId = tempIssueId issueDetailsCache.Add tempIssueId, tempIssueWorkDetails End If ' Extract newEstimate and store to issue If tempJsonIssue.Item("timeC").Exists("newEstimate") Then tempIssueWorkDetails.workRemaining = tempJsonIssue.Item("timeC").Item("newEstimate") / 3600 End If ' Extract date and verify that it is within Sprint dates If tempJsonIssue.Item("timeC").Exists("changeDate") And _ tempJsonIssue.Item("timeC").Exists("timeSpent") Then tempChangeDate = tempJsonIssue.Item("timeC").Item("changeDate") * 1 If (tempChangeDate >= sprintStartEpochMilliseconds) And _ (tempChangeDate <= sprintEndEpochMilliseconds) Then tempIssueWorkDetails.workLogged = tempIssueWorkDetails.workLogged + _ tempJsonIssue.Item("timeC").Item("timeSpent") / 3600 End If End If End If Next index Next ' Now loop through all issues in the cache and sum up time work and time remaining For Each issueWorkDetails In issueDetailsCache.Items tempTimeRemaining = tempTimeRemaining + issueWorkDetails.workRemaining tempTimeSpent = tempTimeSpent + issueWorkDetails.workLogged Next extractSprintContents.sumTimeRemaining = tempTimeRemaining extractSprintContents.sumTimeSpent = tempTimeSpent End If Else extractSprintContents.isValid = False extractSprintContents.errorString = sprintDetailsResult End If End Function Public Function EncodeBase64(text As String) As String Dim arrData() As Byte arrData = StrConv(text, vbFromUnicode) Dim objXML As MSXML2.DOMDocument Dim objNode As MSXML2.IXMLDOMElement Set objXML = New MSXML2.DOMDocument Set objNode = objXML.createElement("b64") objNode.DataType = "bin.base64" objNode.nodeTypedValue = arrData EncodeBase64 = objNode.text Set objNode = Nothing Set objXML = Nothing End Function ' VBJSON is a VB6 adaptation of the VBA JSON project at http://code.google.com/p/vba-json/ ' Some bugs fixed, speed improvements added for VB6 by Michael Glaser (vbjson@ediy.co.nz) ' BSD Licensed Public Function GetParserErrors() As String GetParserErrors = psErrors End Function Public Function ClearParserErrors() As String psErrors = "" End Function ' ' parse string and create JSON object ' Public Function parse(ByRef str As String) As Object Dim index As Long index = 1 psErrors = "" On Error Resume Next Call skipChar(str, index) Select Case Mid(str, index, 1) Case "{" Set parse = parseObject(str, index) Case "[" Set parse = parseArray(str, index) Case Else psErrors = "Invalid JSON" End Select End Function ' ' parse collection of key/value ' Private Function parseObject(ByRef str As String, ByRef index As Long) As Dictionary Set parseObject = New Dictionary Dim sKey As String ' "{" Call skipChar(str, index) If Mid(str, index, 1) <> "{" Then psErrors = psErrors & "Invalid Object at position " & index & " : " & Mid(str, index) & vbCrLf Exit Function End If index = index + 1 Do Call skipChar(str, index) If "}" = Mid(str, index, 1) Then index = index + 1 Exit Do ElseIf "," = Mid(str, index, 1) Then index = index + 1 Call skipChar(str, index) ElseIf index > Len(str) Then psErrors = psErrors & "Missing '}': " & Right(str, 20) & vbCrLf Exit Do End If ' add key/value pair sKey = parseKey(str, index) On Error Resume Next parseObject.Add sKey, parseValue(str, index) If Err.Number <> 0 Then psErrors = psErrors & Err.Description & ": " & sKey & vbCrLf Exit Do End If Loop eh: End Function ' ' parse list ' Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection Set parseArray = New Collection ' "[" Call skipChar(str, index) If Mid(str, index, 1) <> "[" Then psErrors = psErrors & "Invalid Array at position " & index & " : " + Mid(str, index, 20) & vbCrLf Exit Function End If index = index + 1 Do Call skipChar(str, index) If "]" = Mid(str, index, 1) Then index = index + 1 Exit Do ElseIf "," = Mid(str, index, 1) Then index = index + 1 Call skipChar(str, index) ElseIf index > Len(str) Then psErrors = psErrors & "Missing ']': " & Right(str, 20) & vbCrLf Exit Do End If ' add value On Error Resume Next parseArray.Add parseValue(str, index) If Err.Number <> 0 Then psErrors = psErrors & Err.Description & ": " & Mid(str, index, 20) & vbCrLf Exit Do End If Loop End Function ' ' parse string / number / object / array / true / false / null ' Private Function parseValue(ByRef str As String, ByRef index As Long) Call skipChar(str, index) Select Case Mid(str, index, 1) Case "{" Set parseValue = parseObject(str, index) Case "[" Set parseValue = parseArray(str, index) Case """", "'" parseValue = parseString(str, index) Case "t", "f" parseValue = parseBoolean(str, index) Case "n" parseValue = parseNull(str, index) Case Else parseValue = parseNumber(str, index) End Select End Function ' ' parse string ' Private Function parseString(ByRef str As String, ByRef index As Long) As String Dim quote As String Dim Char As String Dim Code As String Dim SB As String Call skipChar(str, index) quote = Mid(str, index, 1) index = index + 1 Do While index > 0 And index <= Len(str) Char = Mid(str, index, 1) Select Case (Char) Case "\" index = index + 1 Char = Mid(str, index, 1) Select Case (Char) Case """", "\", "/", "'" SB = SB & Char index = index + 1 Case "b" SB = SB & vbBack index = index + 1 Case "f" SB = SB & vbFormFeed index = index + 1 Case "n" SB = SB & vbLf index = index + 1 Case "r" SB = SB & vbCr index = index + 1 Case "t" SB = SB & vbTab index = index + 1 Case "u" index = index + 1 Code = Mid(str, index, 4) SB = SB & ChrW(Val("&h" + Code)) index = index + 4 End Select Case quote index = index + 1 parseString = SB Exit Function Case Else SB = SB & Char index = index + 1 End Select Loop parseString = SB End Function ' ' parse number ' Private Function parseNumber(ByRef str As String, ByRef index As Long) Dim Value As String Dim Char As String Call skipChar(str, index) Do While index > 0 And index <= Len(str) Char = Mid(str, index, 1) If InStr("+-0123456789.eE", Char) Then Value = Value & Char index = index + 1 Else parseNumber = CDec(Value) Exit Function End If Loop End Function ' ' parse true / false ' Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean Call skipChar(str, index) If Mid(str, index, 4) = "true" Then parseBoolean = True index = index + 4 ElseIf Mid(str, index, 5) = "false" Then parseBoolean = False index = index + 5 Else psErrors = psErrors & "Invalid Boolean at position " & index & " : " & Mid(str, index) & vbCrLf End If End Function ' ' parse null ' Private Function parseNull(ByRef str As String, ByRef index As Long) Call skipChar(str, index) If Mid(str, index, 4) = "null" Then parseNull = Null index = index + 4 Else psErrors = psErrors & "Invalid null value at position " & index & " : " & Mid(str, index) & vbCrLf End If End Function Private Function parseKey(ByRef str As String, ByRef index As Long) As String Dim dquote As Boolean Dim squote As Boolean Dim Char As String Call skipChar(str, index) Do While index > 0 And index <= Len(str) Char = Mid(str, index, 1) Select Case (Char) Case """" dquote = Not dquote index = index + 1 If Not dquote Then Call skipChar(str, index) If Mid(str, index, 1) <> ":" Then psErrors = psErrors & "Invalid Key at position " & index & " : " & parseKey & vbCrLf Exit Do End If End If Case "'" squote = Not squote index = index + 1 If Not squote Then Call skipChar(str, index) If Mid(str, index, 1) <> ":" Then psErrors = psErrors & "Invalid Key at position " & index & " : " & parseKey & vbCrLf Exit Do End If End If Case ":" index = index + 1 If Not dquote And Not squote Then Exit Do Else parseKey = parseKey & Char End If Case Else If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Char) Then Else parseKey = parseKey & Char End If index = index + 1 End Select Loop End Function ' ' skip special character ' Private Sub skipChar(ByRef str As String, ByRef index As Long) Dim bComment As Boolean Dim bStartComment As Boolean Dim bLongComment As Boolean Do While index > 0 And index <= Len(str) Select Case Mid(str, index, 1) Case vbCr, vbLf If Not bLongComment Then bStartComment = False bComment = False End If Case vbTab, " ", "(", ")" Case "/" If Not bLongComment Then If bStartComment Then bStartComment = False bComment = True Else bStartComment = True bComment = False bLongComment = False End If Else If bStartComment Then bLongComment = False bStartComment = False bComment = False End If End If Case "*" If bStartComment Then bStartComment = False bComment = True bLongComment = True Else bStartComment = True End If Case Else If Not bComment Then Exit Do End If End Select index = index + 1 Loop End Sub Public Function toString(ByRef obj As Variant) As String Dim SB As New cStringBuilder Select Case VarType(obj) Case vbNull SB.Append "null" Case vbDate SB.Append """" & CStr(obj) & """" Case vbString SB.Append """" & Encode(obj) & """" Case vbObject Dim bFI As Boolean Dim i As Long bFI = True If TypeName(obj) = "Dictionary" Then SB.Append "{" Dim keys keys = obj.keys For i = 0 To obj.Count - 1 If bFI Then bFI = False Else SB.Append "," Dim key key = keys(i) SB.Append """" & key & """:" & toString(obj.Item(key)) Next i SB.Append "}" ElseIf TypeName(obj) = "Collection" Then SB.Append "[" Dim Value For Each Value In obj If bFI Then bFI = False Else SB.Append "," SB.Append toString(Value) Next Value SB.Append "]" End If Case vbBoolean If obj Then SB.Append "true" Else SB.Append "false" Case vbVariant, vbArray, vbArray + vbVariant Dim sEB SB.Append multiArray(obj, 1, "", sEB) Case Else SB.Append Replace(obj, ",", ".") End Select toString = SB.toString Set SB = Nothing End Function Private Function Encode(str) As String Dim SB As New cStringBuilder Dim i As Long Dim j As Long Dim aL1 As Variant Dim aL2 As Variant Dim c As String Dim p As Boolean aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9) aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74) For i = 1 To Len(str) p = True c = Mid(str, i, 1) For j = 0 To 7 If c = Chr(aL1(j)) Then SB.Append "\" & Chr(aL2(j)) p = False Exit For End If Next If p Then Dim a a = AscW(c) If a > 31 And a < 127 Then SB.Append c ElseIf a > -1 Or a < 65535 Then SB.Append "\u" & String(4 - Len(Hex(a)), "0") & Hex(a) End If End If Next Encode = SB.toString Set SB = Nothing End Function Private Function multiArray(aBD, iBC, sPS, ByRef sPT) ' Array BoDy, Integer BaseCount, String PoSition Dim iDU As Long Dim iDL As Long Dim i As Long On Error Resume Next iDL = LBound(aBD, iBC) iDU = UBound(aBD, iBC) Dim SB As New cStringBuilder Dim sPB1, sPB2 ' String PointBuffer1, String PointBuffer2 If Err.Number = 9 Then sPB1 = sPT & sPS For i = 1 To Len(sPB1) If i <> 1 Then sPB2 = sPB2 & "," sPB2 = sPB2 & Mid(sPB1, i, 1) Next ' multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")")) SB.Append toString(aBD(sPB2)) Else sPT = sPT & sPS SB.Append "[" For i = iDL To iDU SB.Append multiArray(aBD, iBC + 1, i, sPT) If i < iDU Then SB.Append "," Next SB.Append "]" sPT = Left(sPT, iBC - 2) End If Err.Clear multiArray = SB.toString Set SB = Nothing End Function ' Miscellaneous JSON functions Public Function StringToJSON(st As String) As String Const FIELD_SEP = "~" Const RECORD_SEP = "|" Dim sFlds As String Dim sRecs As New cStringBuilder Dim lRecCnt As Long Dim lFld As Long Dim fld As Variant Dim rows As Variant lRecCnt = 0 If st = "" Then StringToJSON = "null" Else rows = Split(st, RECORD_SEP) For lRecCnt = LBound(rows) To UBound(rows) sFlds = "" fld = Split(rows(lRecCnt), FIELD_SEP) For lFld = LBound(fld) To UBound(fld) Step 2 sFlds = (sFlds & IIf(sFlds <> "", ",", "") & """" & fld(lFld) & """:""" & toUnicode(fld(lFld + 1) & "") & """") Next 'fld sRecs.Append IIf((Trim(sRecs.toString) <> ""), "," & vbCrLf, "") & "{" & sFlds & "}" Next 'rec StringToJSON = ("( {""Records"": [" & vbCrLf & sRecs.toString & vbCrLf & "], " & """RecordCount"":""" & lRecCnt & """ } )") End If End Function Public Function RStoJSON(rs As ADODB.Recordset) As String On Error GoTo errHandler Dim sFlds As String Dim sRecs As New cStringBuilder Dim lRecCnt As Long Dim fld As ADODB.Field lRecCnt = 0 If rs.State = adStateClosed Then RStoJSON = "null" Else If rs.EOF Or rs.BOF Then RStoJSON = "null" Else Do While Not rs.EOF And Not rs.BOF lRecCnt = lRecCnt + 1 sFlds = "" For Each fld In rs.Fields sFlds = (sFlds & IIf(sFlds <> "", ",", "") & """" & fld.name & """:""" & toUnicode(fld.Value & "") & """") Next 'fld sRecs.Append IIf((Trim(sRecs.toString) <> ""), "," & vbCrLf, "") & "{" & sFlds & "}" rs.MoveNext Loop RStoJSON = ("( {""Records"": [" & vbCrLf & sRecs.toString & vbCrLf & "], " & """RecordCount"":""" & lRecCnt & """ } )") End If End If Exit Function errHandler: End Function Public Function toUnicode(str As String) As String Dim x As Long Dim uStr As New cStringBuilder Dim uChrCode As Integer For x = 1 To Len(str) uChrCode = Asc(Mid(str, x, 1)) Select Case uChrCode Case 8: ' backspace uStr.Append "\b" Case 9: ' tab uStr.Append "\t" Case 10: ' line feed uStr.Append "\n" Case 12: ' formfeed uStr.Append "\f" Case 13: ' carriage return uStr.Append "\r" Case 34: ' quote uStr.Append "\""" Case 39: ' apostrophe uStr.Append "\'" Case 92: ' backslash uStr.Append "\\" Case 123, 125: ' "{" and "}" uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4)) Case Is < 32, Is > 127: ' non-ascii characters uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4)) Case Else uStr.Append Chr$(uChrCode) End Select Next toUnicode = uStr.toString Exit Function End Function Private Sub Class_Initialize() psErrors = "" End Sub
You must be a registered user to add a comment. If you've already registered, sign in. Otherwise, register and sign in.