' Пользователя Redmine, от имени которого будет создана задача,
' можно не указывать в тексте url, тогда окно с запросом
' логина и пароля будет выведено автоматически
Const REDMINE_URL = "http://redmine_url"
' но можно и жестко задать
'Const REDMINE_URL = "http://user:password@redmine_url
' гиперссылка и номер задачи, которые нам вернет функция PostIssue
' (к сожалению, я не нашел, как вернуть эти значения в одной функции
' без глобальных переменных, не строя дополнительных массивов)
Public issue_url, issue_id As String
Sub Redmine_Create_Issue()
Dim ReqStatus As Boolean
Dim PROJECT_ID, TRACKER_ID, ASSIGNED_TO_ID, CATEGORY_ID As Integer
Dim Subject, Body, DUE_DATE, REDMINE_API_KEY As String
' ID должны быть из базы Redmine
' Позже я опишу, как их можно вытащить из Redmine
PROJECT_ID = 32
TRACKER_ID = 1
ASSIGNED_TO_ID = 20 'ID пользователя, на которого будет назначена задача
' Сюда можно вписать любые данные из нашей таблицы
Subject = "Тема задачи"
Body = "Текст задачи"
' Плановая дата завершения задачи
DUE_DATE = Format(ActiveSheet.Cells(ActiveCell.Row, 12), "yyyy-mm-dd")
'REDMINE_API_KEY = "e11234567891234567891234567891234567bce0" ' если используется API key
' Запускаем задачу в редмайн при помощи функции
ReqStatus = PostIssue(PROJECT_ID, TRACKER_ID, ASSIGNED_TO_ID, Subject, Body, DUE_DATE, _
REDMINE_API_KEY, CATEGORY_ID)
' Проверяем, что задача отправлена
If ReqStatus <> False Then
MsgBox "Redmine: Ok, задача отправлена"
' Добавим в нашу таблицу во 2й столбец гипперссылку на созданную задачу
ActiveSheet.Cells(ActiveCell.Row, 2) = issue_id
ActiveSheet.Hyperlinks.Add Range("B" & ActiveCell.Row), issue_url, "", _
"Открыть задачу" & issue_url
' Дату создания задачи вписываем в 11й столбец на листе)
ActiveSheet.Cells(ActiveCell.Row, 11) = Date
Else
MsgBox "Redmine: Ошибка, обратитесь к администратору"
End If
End Sub
' Сама функция отправки задачи в формате xml
Function PostIssue(ByVal PROJECT_ID As Integer, ByVal TRACKER_ID As Integer, _
ByVal ASSIGNED_TO_ID As Integer, ByVal Subject As String, _
ByVal Body As String, ByVal DUE_DATE As String, _
ByVal REDMINE_API_KEY As String, ByVal CATEGORY_ID As String)
Dim xhr
Dim RequestURL As String
Dim RequestBody As String
RequestURL = REDMINE_URL & "/issues.xml?format=xml"
' если используется API key
'RequestURL = REDMINE_URL & "/issues.xml?format=xml&key=" & REDMINE_API_KEY
Set xhr = CreateObject("Microsoft.XMLHTTP")
xhr.Open "GET", RequestURL, False
xhr.SetRequestHeader "Content-Type", "text/xml"
RequestBody = "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>"
RequestBody = RequestBody & "<issue>"
RequestBody = RequestBody & "<project_id>" & PROJECT_ID & "</project_id>"
RequestBody = RequestBody & "<tracker_id>" & TRACKER_ID & "</tracker_id>"
RequestBody = RequestBody & "<assigned_to_id>" & ASSIGNED_TO_ID & "</assigned_to_id>"
RequestBody = RequestBody & "<subject>" & Subject & "</subject>"
RequestBody = RequestBody & "<description>" & Body & "</description>"
RequestBody = RequestBody & "<due_date>" & DUE_DATE & "</due_date>"
RequestBody = RequestBody & "</issue>"
' Проверяем, что задача отправлена
xhr.Send (RequestBody)
If xhr.Status = 201 Then
PostIssue = True
Else
PostIssue = False
End If
' гиперссылка и номер задачи
issue_url = xhr.getResponseHeader("location")
issue_id = Right(issue_url, Len(issue_url) - InStrRev(issue_url, "/"))
End Function
PROJECT_ID = 32
TRACKER_ID = 1
ASSIGNED_TO_ID = 20
PROJECT_ID = 0
TRACKER_ID = 0
ASSIGNED_TO_ID = 0
Set ID_WS = Application.ThisWorkbook.Sheets("ID")
last_row = ID_WS.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To last_row
If ActiveSheet.Cells(ActiveCell.Row, 3) = ID_WS.Cells(i, 2) Then
PROJECT_ID = ID_WS.Cells(i, 3)
End If
If ActiveSheet.Cells(ActiveCell.Row, 4) = ID_WS.Cells(i, 5) Then
TRACKER_ID = ID_WS.Cells(i, 6)
End If
If ActiveSheet.Cells(ActiveCell.Row, 10) = ID_WS.Cells(i, 8) Then
ASSIGNED_TO_ID = ID_WS.Cells(i, 9)
End If
If PROJECT_ID <> 0 And TRACKER_ID <> 0 And ASSIGNED_TO_ID <> 0 Then Exit For
Next
Function XMLtoArray(ByVal RequestURL, ByVal ElementsByTagName As String, ByVal arr) As Variant
' функция получает xml и переводит его в массив
' ElementsByTagName - начальный xml узел для обработки
' arr - массив узлов и аттрибутов
Dim strXML As String
Dim currNode As IXMLDOMNode
If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
' делаем запрос и получаем xml
Set xhr = CreateObject("Microsoft.XMLHTTP")
xhr.Open "GET", RequestURL, False
xhr.SetRequestHeader "Content-Type", "text/xml"
xhr.Send
strXML = xhr.responseText
' парсим xml
' необходимо подключить библиотеку Microsoft XML, v6.0 (Tools --> Reference)
Set xmlParser = CreateObject("MSXML2.DOMDocument")
If Not xmlParser.LoadXML(strXML) Then
Err.Raise xmlParser.parseError.ErrorCode, , XDoc.parseError.reason
End If
Set colNodes = xmlParser.getElementsByTagName(ElementsByTagName)
ReDim newarr(0 To colNodes.Length, 0 To UBound(arr))
N = 0
For Each node_item In colNodes
For i = 0 To UBound(arr)
If Not arr(i) Like "*@*" Then
If Not IsNull(node_item.SelectSingleNode(arr(i))) Then
newarr(N, i) = node_item.SelectSingleNode(arr(i)).Text
End If
Else
For Each nodeChild In node_item.ChildNodes
If part1(arr(i)) = nodeChild.nodeName Then
newarr(N, i) = nodeChild.getAttribute(part2(arr(i)))
If nodeChild.ChildNodes.Length > 0 Then
p = 0
For Each nodeChildChild In nodeChild.ChildNodes
If p = 0 Then
newarr(N, i) = nodeChildChild.getAttribute(part2(arr(i)))
Else
newarr(N, i) = newarr(N, i) & "@" & nodeChildChild.getAttribute(part2(arr(i)))
End If
p = 1
Next
End If
End If
Next
End If
Next
N = N + 1
Next
XMLtoArray = newarr
End Function
Function SWAP(ByVal arr As Variant, ByVal NewColumnsOrder$) As Variant
' Функция принимает в качестве параметра двумерный массив arr (для перестановки столбцов)
' и текстовую строку NewColumnsOrder с новым порядком столбцов в формате ",,5,6,8,,9-15,18,2,9-11,,1,4,,21,"
' Возвращает массив, в котором столбцы переставлены в нужном порядке
On Error Resume Next
cols = Split(Replace(NewColumnsOrder$, " ", ""), ","): Dim n As Long: ReDim colArr(0 To 0)
For i = LBound(cols) To UBound(cols)
Select Case True
Case cols(i) = "", Val(cols(i)) < 0
colArr(UBound(colArr)) = -1: ReDim Preserve colArr(0 To UBound(colArr) + 1)
Case IsNumeric(cols(i))
colArr(UBound(colArr)) = cols(i): ReDim Preserve colArr(0 To UBound(colArr) + 1)
Case cols(i) Like "*#-#*"
spl = Split(cols(i), "-")
If UBound(spl) = 1 Then
If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then
For j = Val(spl(0)) To Val(spl(1)) Step IIf(Val(spl(0)) > Val(spl(1)), -1, 1)
colArr(UBound(colArr)) = j: ReDim Preserve colArr(0 To UBound(colArr) + 1)
Next j
End If
End If
End Select
Next i
ReDim Preserve colArr(0 To UBound(colArr) - 1)
ColumnsArray = colArr
ReDim tmpArr(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(ColumnsArray) + 1)
For j = LBound(ColumnsArray) To UBound(ColumnsArray)
If Val(ColumnsArray(j)) >= 0 Then
For i = LBound(arr, 1) To UBound(arr, 1): tmpArr(i, j + LBound(arr, 2)) = arr(i, Val(ColumnsArray(j))): Next i
End If
Next j
SWAP = tmpArr
End Function
RequestURL = REDMINE_URL & "/projects.xml?include=trackers"
Arr_childNodes_projects = Array("id", "name", "trackers@id", "trackers@name", _
"identifier", "description", "parent@id", "parent@name", _
"status", "is_public", "created_on", "updated_on")
Arr_projects = XMLtoArray(RequestURL, "project", Arr_childNodes_projects)
Arr_projects_SWAP = SWAP(Arr_projects, 1)
RequestURL_status = REDMINE_URL & "/issue_statuses.xml"
Arr_childNodes_status = Array("id", "name", "is_closed")
Arr_statuses = XMLtoArray(RequestURL_status, "issue_status", Arr_childNodes_status)
Arr_statuses_SWAP = SWAP(Arr_statuses, 1)
RequestURL_priorities = REDMINE_URL & "/enumerations/issue_priorities.xml"
Arr_childNodes_priorities = Array("id", "name", "is_default")
Arr_priorities = XMLtoArray(RequestURL_priorities, "issue_priority", Arr_childNodes_priorities)
Arr_priorities_SWAP = SWAP(Arr_priorities, 1)
RequestURL_memberships = REDMINE_URL & "/projects/" & Arr_projects(i, 0) & "/memberships.xml?limit=300"
Arr_childNodes_memberships = Array("user@id", "user@name", "project@id", "project@name", "roles@id", "roles@name")
Arr_memberships = XMLtoArray(RequestURL_memberships, "membership", Arr_childNodes_memberships)
Arr_memberships_SWAP = SWAP(Arr_memberships, 1)
RequestURL_issues = REDMINE_URL & "/issues.xml?project_id=" & Arr_projects(i, 0)
Arr_childNodes_issues = Array("id", "subject")
Arr_issues = XMLtoArray(RequestURL_issues, "issue", Arr_childNodes_issues)
Arr_issues_SWAP = SWAP(Arr_issues, "0,1")
ComboBox_parent_issue.List = Arr_issues_SWAP
К сожалению, не доступен сервер mySQL