スポンサーサイト

上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

NozbeをVBAで動かす:プロジェクト&タスクの取得

Nozbeに登録されているプロジェクトやタスクを取得するソースです。

ちなみに、sAPIKeyという変数名(String型)で、CONSTとかで以下を動かすモジュールに変数を作成してください。
その変数にAPIKeyを代入しておいてください。

※ APIKeyの取得は、この1つ前の記事に書いております。あわせてご参照ください。

’プロジェクトを取得する ・・・ついでに、タスクを取得する部分も入れ込んでます
 Public Function GetNozbeProjects()
    Dim xmlHTTP As Object
    Dim txt As String
    Dim bufs() As String, itms() As String, vals() As String
    
    Set xmlHTTP = getXMLHTTP()
    If xmlHTTP Is Nothing Then
        MsgBox "XMLHTTPオブジェクトの生成に失敗しました。", vbExclamation
        Exit Function
    End If
    xmlHTTP.Open "GET", "http://www.nozbe.com/api/projects/key-" & sAPIKey, False
    xmlHTTP.send ""
    txt = xmlHTTP.responseText
    
    '*-- JSONデータの処理 --*
    txt = Mid(txt, 3, Len(txt) - 4) '両端の[{ }]を除去
    bufs = Split(txt, "},{")
    
    Dim i As Integer, j As Integer
    For i = 0 To UBound(bufs)
        Debug.Print i & "つ目のアイテム"
        itms = Split(bufs(i), ",")
        For j = 0 To UBound(itms)
            vals = Split(itms(j), ":")
            If InStr(vals(0), "name") > 0 Then
                vals(1) = UNItoSTR(vals(1)) ' UNICODEの処理
            End If
            Debug.Print vals(0), vals(1)
        Next j
        
        GetNozbeTasks Split(itms(0), ":")(1) ’プロジェクトIDを渡して、そのプロジェクトのタスクを取得
    Next i
    
    Set xmlHTTP = Nothing
End Function
’タスク情報を取得(引数=プロジェクトID)
Public Sub GetNozbeTasks(ByVal PJID As String)
    Dim xmlHTTP As Object
    Dim txt As String
    Dim bufs() As String, itms() As String, vals() As String
    
    'プロジェクトIDにダブルコーテが付いてたら削除
    If Left(PJID, 1) = """" Then
        PJID = Mid(PJID, 2, Len(PJID) - 2) '両端の"を除去
    End If
    
    Set xmlHTTP = getXMLHTTP()
    If xmlHTTP Is Nothing Then
        MsgBox "XMLHTTPオブジェクトの生成に失敗しました。", vbExclamation
        Exit Sub
    End If
    xmlHTTP.Open "GET", "http://www.nozbe.com/api/actions/what-project/id-" & PJID & "/key-" & sAPIKey, False
    xmlHTTP.send ""
    txt = xmlHTTP.responseText
    '*-- JSONデータの処理 --*
    txt = Mid(txt, 3, Len(txt) - 4) '両端の[{ }]を除去
    bufs = Split(txt, "},{")
    
    Dim i As Integer, j As Integer
    For i = 0 To UBound(bufs)
        '1つ目のアイテム
        itms = Split(bufs(i), ",")
        Debug.Print i + 1 & "つ目のアイテム"
        For j = 0 To UBound(itms)
            vals = Split(itms(j), ":")
            If InStr(vals(0), "name") > 0 Then
                vals(1) = UNItoSTR(vals(1)) ' UNICODEの処理
            End If
            Debug.Print vals(0), vals(1)
        Next j
    Next i
    Set xmlHTTP = Nothing
End Sub
'-- UNICODE -> STRINGに変換 --------------------
Public Function UNItoSTR(ByVal sUNI As String) As String
    Dim uni(1) As Byte, str As String
    Dim i As Integer
    
    sUNI = RepStr(sUNI, "\/", "/")
    
    For i = 1 To Len(sUNI)
        If Mid(sUNI, i, 2) = "\u" Then
            uni(0) = CLng("&H" & Mid(sUNI, i + 4, 2))
            uni(1) = CLng("&H" & Mid(sUNI, i + 2, 2))
            str = str & CStr(uni)
            i = i + 5
        Else
            str = str & Mid(sUNI, i, 1)
        End If
    Next i
    
    UNItoSTR = str
End Function
'-- WEBの情報を取ってくるオブジェクト ---------------
Public Function getXMLHTTP() As Object
  Dim L As Long
  On Error Resume Next
  'セキュリティレベル & パフォーマンスの高い MSXML4を優先して作成する。
  '対応バージョンのXMLHTTPがインストールされていない場合は、
  '下位バージョンのXMLHTTPオブジェクトの生成を試みる。
  For L = 0 To 4
    Select Case L
     Case 0
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP.4.0")
     Case 1
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP.3.0")
     Case 2
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP.2.6")
     Case 3
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP")
     Case 4
      Set getXMLHTTP = CreateObject("Microsoft.XMLHTTP")
    End Select
    If Not getXMLHTTP Is Nothing Then
        Exit For
    End If
  Next
End Function

NozbeをVBAで動かす:APIKeyの取得

VBでNozbeを動かすためのサンプルです。
整理しやすいように、小出しでアップします。 

以下は、NozbeAPIを使うためのAPIKeyを取得するサンプルです。
※ Nozbeにログインしてアカウント情報を見れば、載ってるものなので、わざわざVBで取得する必要もないかおしれませんが。。。

Sub ttttest()
    MsgBox GetAPIKey("aaa@bbb.com", "abcdefg")
End Sub
Public Function GetAPIKey(id As String, pw As String) As String
    Dim xmlHTTP As Object
    Dim txt As String
    
    
    Set xmlHTTP = getXMLHTTP()
    If xmlHTTP Is Nothing Then
        MsgBox "XMLHTTPオブジェクトの生成に失敗", vbExclamation
        Exit Function
    End If
    xmlHTTP.Open "GET", "http://www.nozbe.com/api/login/email-" & id & "/password-" & pw, False
    xmlHTTP.send ""
    txt = xmlHTTP.responseText
    txt = Mid(txt, 2, Len(txt) - 2) '両端の{}を除去
    GetAPIKey = Split(txt, ":")(1)
    GetAPIKey = Mid(GetAPIKey, 2, Len(GetAPIKey) - 2) '両端のダブルコーテを除去
    
    Set xmlHTTP = Nothing
End Function

'-- WEBの情報を取ってくるオブジェクト ---------------
Public Function getXMLHTTP() As Object
  Dim L As Long
  On Error Resume Next
  'セキュリティレベル & パフォーマンスの高い MSXML4を優先して作成する。
  '対応バージョンのXMLHTTPがインストールされていない場合は、
  '下位バージョンのXMLHTTPオブジェクトの生成を試みる。
  For L = 0 To 4
    Select Case L
     Case 0
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP.4.0")
     Case 1
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP.3.0")
     Case 2
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP.2.6")
     Case 3
      Set getXMLHTTP = CreateObject("Msxml2.XMLHTTP")
     Case 4
      Set getXMLHTTP = CreateObject("Microsoft.XMLHTTP")
    End Select
    If Not getXMLHTTP Is Nothing Then
        Exit For
    End If
  Next
End Function

Notesの書き出しファイルを読み込むプログラム

Option Explicit

Public Sub データクリア()
Cells.ClearContents
End Sub

Public Sub Notesデータ取り込み()

Dim buf As String
Dim nStart As Long 'nStart=bufの何個目から取るか
Dim dic As New Scripting.Dictionary
Dim buffer() As Byte, fileID As Integer
Dim r As Integer
Dim fn As String

'ファイルの取得
fn = prcApplicationGetOpenFilename
If fn = "" Then
MsgBox "ファイル名を指定してください。一旦終了"
Exit Sub
End If



fileID = FreeFile
Open fn For Binary As #fileID
ReDim buffer(LOF(fileID))
Get #fileID, , buffer
Close #fileID

nStart = 0
r = 2

データクリア
Application.ScreenUpdating = False

Do
nStart = GetLine(buffer, nStart, buf)

If InStr(1, buf, ":") > 0 Then
Dim Key As String
Key = Left(buf, InStr(1, buf, ":") - 1)
If dic.Exists(Key) Then
Else
With Range("IV1").End(xlToLeft).Offset(0, 1)
.Value = Key
dic.Add Key, .Column
End With
End If

buf = Replace(buf, Chr(1), vbTab) '変な空文字をタブに変える
buf = Replace(buf, Chr(0), vbCrLf) '変な空文字をタブに変える
Cells(r, dic(Key)).Value = Mid(buf, InStr(1, buf, ":") + 3, Len(buf))

End If

'--↓空がテキスト文字取込開始サイン--
If buf = "" Then
Dim msg As String

If dic.Exists("本文") = False Then
With Range("IV1").End(xlToLeft).Offset(0, 1)
.Value = "本文"
dic.Add "本文", .Column
End With
End If

nStart = Get本文(buffer, nStart, buf)
Cells(r, dic("本文")).Value = buf

'最終判定=本文後に改行
If buffer(nStart) = 13 And buffer(nStart + 1) = 10 Then Exit Do

r = r + 1
End If
Loop

Application.ScreenUpdating = True

End Sub


Private Function GetStringFromByte( _
ByRef buf() As Byte, _
ByRef Key() As Byte, _
ByVal nStart As Long, _
ByRef sRes As String) As Long

Dim i As Long, j As Long, k As Long, f As Boolean
Dim res() As Byte

For i = nStart To UBound(buf)
f = True
For j = 0 To UBound(Key)
If buf(i + j) <> Key(j) Then
f = False
Exit For
End If
Next j
If f = True Then
GetStringFromByte = i + UBound(Key) + 1
If i = nStart Then
sRes = ""
Else
ReDim res(i - nStart - 1)
For k = 0 To UBound(res)
res(k) = buf(nStart + k)
Next k
sRes = StrConv(res(), vbUnicode)
End If

Exit Function
End If
Next i
End Function


Private Function GetLine(ByRef buf() As Byte, ByVal nStart As Long, ByRef sRes As String) As Long
Dim Key(1) As Byte
Key(0) = 13: Key(1) = 10 '改行文字
GetLine = GetStringFromByte(buf, Key, nStart, sRes)
End Function

Private Function Get本文(ByRef buf() As Byte, ByVal nStart As Long, ByRef sRes As String) As Long
Dim Key(2) As Byte
Key(0) = 12: Key(1) = 13: Key(2) = 10 '改行文字
Get本文 = GetStringFromByte(buf, Key, nStart, sRes)
End Function




Public Function RepStr(s As String, org As String, rep As String) As String

Dim a As String
Dim i As Long
Dim j As Long
Dim k As Long

a = s
k = Len(org) - 1
j = Len(rep)
i = 1 - j
Do
i = InStr(i + j, a, org)
If i > 0 Then a = Left(a, i - 1) & rep & Right(a, Len(a) - i - k)
Loop Until i = 0

RepStr = a

End Function




Public Function prcApplicationGetOpenFilename() As String

Dim vntFileName As Variant

'ファイルを開くダイアログを開きます
vntFileName = _
Application.GetOpenFilename( _
FileFilter:="すべてのファイル (*.*),*.*" _
, FilterIndex:=1 _
, Title:="読み込みファイルの選択" _
, MultiSelect:=False _
)

'ファイルが選択されているときは
'選択したファイルをWorkbooks.Openメソッドで開きます
If vntFileName <> False Then
prcApplicationGetOpenFilename = vntFileName
End If

End Function

google Calendar APIをVB6やVBAで使う

Google Calendar API や Google Tasks API(ToDoリストのこと)をVB6やVBAで使うためのモジュールをクラス化しました。
ささっと書いたので、挙動不審です(メモリの開放とか)。でも一応動きます。もしこのクラスをバージョンアップされるかたがいらっしゃいましたら、是非教えてください!

!!注意!!
Google tasks(ToDoリストのこと)を使うためには、API Keyなるものを取得しなければなりません。Google CalendarはAPIKEY不要です。

『API Key』でググったらいろいろと出てくるので、そちらをご参考にAPI KEYを取得してください。

Excel for Google Calendar and Tasks

VBA:ウィンドウの切り替え(ウィンドウをアクティブにする)

【VBA】
ウィンドウタイトルからそのウィンドウをアクティブにする(ウィンドウを切り替える)サンプルプログラムです。

Option Explicit

'強制的に最前面にさせる
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
'キャプション取得
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Public Sub test()
Dim objWindow, objShell
Dim MyName As String * 128, ret As Long

Set objShell = CreateObject("Shell.Application")
For Each objWindow In objShell.Windows()
MyName = ""
ret = GetWindowText(objWindow.hWnd, MyName, Len(MyName))
If MyName Like "アクティブにしたいウィンドウのタイトルを入れる(中途半端OK)*" Then
SetForegroundWindow objWindow.hWnd
Exit For
End If
Next
End Sub


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。