VBA操作redmine & Chrome

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")

' 運用

'               wshshell.Run """chrome.exe""" & "http://sever01:6000/redmine/projects/kansaicis/issues?c%5B%5D=cf_4&c%5B%5D=subject&c%5B%5D=assigned_to&c%5B%5D=parent&c%5B%5D=cf_85&f%5B%5D=tracker_id&f%5B%5D=assigned_to_id&f%5B%5D=&group_by=cf_4&op%5Bassigned_to_id%5D=%3D&op%5Btracker_id%5D=%3D&set_filter=1&sort=cf_4%3Adesc%2Cid%3Adesc&utf8=%E2%9C%93&v%5Bassigned_to_id%5D%5B%5D=me&v%5Btracker_id%5D%5B%5D=24"

' 規制

wshshell.Run """chrome.exe""" & "http://sever01:6000/redmine/projects/system_divide/issues?c%5B%5D=cf_4&c%5B%5D=subject&c%5B%5D=assigned_to&c%5B%5D=parent&c%5B%5D=cf_85&f%5B%5D=tracker_id&f%5B%5D=assigned_to_id&f%5B%5D=&group_by=cf_4&op%5Bassigned_to_id%5D=%3D&op%5Btracker_id%5D=%3D&set_filter=1&sort=cf_4%3Adesc%2Cid%3Adesc&utf8=%E2%9C%93&v%5Bassigned_to_id%5D%5B%5D=me&v%5Btracker_id%5D%5B%5D=46"

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