Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function ActivateKeyboardLayout Lib "user32.dll" (ByVal mylanguage As Long, ByVal flag As Boolean) As Long
Public Sub Redmine工数入力()
Const sumiCel As String = "B6"
'工数画面入力ループ
Dim i As Integer
i = 0
Do While 1 = 1
'済でない場合
If Range(sumiCel).Offset(i, 0).Value <> "済" Then
'入力項目が全てブランクでない場合
If Range(sumiCel).Offset(i, 1).Value <> "" _
And Range(sumiCel).Offset(i, 6).Value <> "" _
And Range(sumiCel).Offset(i, 7).Value <> "" _
And Range(sumiCel).Offset(i, 8).Value <> "" _
And Range(sumiCel).Offset(i, 11).Value <> "" Then
'入力処理
Call 工数入力ByAPI(sumiCel, i)
Range(sumiCel).Offset(i, 0).Value = "済"
Else
'登録後確認
Dim wshshell As Object
Set wshshell = CreateObject("wscript.shell")
' 運用
' 規制
Sleep 4000
CopyToClipboard (Range("J1").Value)
Sleep 2000
wshshell.SendKeys "^V"
Sleep 2000
wshshell.SendKeys "{TAB}"
Sleep 2000
CopyToClipboard (Range("J2").Value)
Sleep 2000
wshshell.SendKeys "^V"
Sleep 2000
wshshell.SendKeys "{TAB}"
Sleep 2000
wshshell.SendKeys "{ }"
Set wshshell = Nothing
Exit Do
End If
End If
i = i + 1
Loop
'処理完了
MsgBox "処理完了！"
End Sub
Private Function 工数入力ByAPI(sumiCel, i)
Dim param As String
Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
xmlhttp.Open "GET", "http://sever01:6000/redmine/users/current.json", False
xmlhttp.setRequestHeader "Authorization", "Basic " + Base64Encode(Range("J1").Value + ":" + Range("J2").Value)
xmlhttp.send
param = "{""issue"":{""project_id"":45,""tracker_id"":46,""status_id"":15,""priority_id"":12,""assigned_to_id"":" + GetUserId(xmlhttp.responseText) + ",""start_date"":""" + Format(Now, "yyyy-mm-dd") _
+ """,""subject"":""" + Range(sumiCel).Offset(i, 1).Value + """,""parent_issue_id"":" + CStr(Range(sumiCel).Offset(i, 8).Value) _
+ ",""custom_fields"":[{""id"":4,""value"":""" + Range(sumiCel).Offset(i, 11).Value + """},{""id"":85,""value"":""" + CStr(Range(sumiCel).Offset(i, 7).Value) + """}, {""id"":236,""value"":""" + CStr(Range(sumiCel).Offset(i, 12).Value) + """},{""id"":240,""value"":""" + CStr(Range(sumiCel).Offset(i, 13).Value) + """} , {""id"":245,""value"":""" + CStr(Range(sumiCel).Offset(i, 14).Value) + """},{""id"":246,""value"":""" + CStr(Range(sumiCel).Offset(i, 15).Value) + """}]}}"
'xmlhttp.Open "GET", "http://sever01:6000/redmine/issues.json?issue_id=250580", False
'xmlhttp.Open "DELETE", "http://sever01:6000/redmine/issues/259215.json", False
xmlhttp.Open "POST", "http://sever01:6000/redmine/issues.json", False
xmlhttp.setRequestHeader "Content-Type", "application/json"
xmlhttp.setRequestHeader "Authorization", "Basic " + Base64Encode(Range("J1").Value + ":" + Range("J2").Value)
xmlhttp.send param
Debug.Print xmlhttp.responseText
Set xmlhttp = Nothing
End Function
Private Function Base64Encode(sText As String) As String
Dim oXML, oNode As Object
Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
Set oNode = oXML.createElement("base64")
oNode.DataType = "bin.base64"
oNode.nodeTypedValue = StreamStringToBinary(sText)
Base64Encode = oNode.Text
Set oXML = Nothing
Set oNode = Nothing
End Function
Private Function StreamStringToBinary(sText As String) As Variant
Dim ado As Object
Set ado = CreateObject("ADODB.Stream")
ado.Type = 2
ado.Charset = "ascii"
ado.Open
ado.WriteText sText
ado.Position = 0
ado.Type = 1
StreamStringToBinary = ado.Read
ado.Close
Set ado = Nothing
End Function
Private Function GetUserId(sText As String) As String
Dim sc, jsObj As Object
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
Set jsObj = sc.eval("eval(" + sText + ")")
GetUserId = jsObj.user.id
End Function
Private Sub CopyToClipboard(sText As String)
Dim data As Object
Set data = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
data.SetText sText
data.PutInClipboard
End Sub
