WPSender

Dim xhr As XMLHTTP

Dim mUserName As String
Dim mPassword As String
Dim mURL As String



Public Sub init(url As String)
      
    mURL = url & "/xmlrpc.php"
    
End Sub

'ユーザとパスワードをセット
Public Sub setUser(userName As String, password As String)

   mUserName = userName
   mPassword = password
   
End Sub

'wordpressに投稿
Public Function postToWP(title As String, description As String, publish As String) As String
    Dim param As String
    Dim contents As String
    
    contents = "<struct>" & _
        "<member>" & _
            "<name>title</name>" & _
            "<value><string>" & title & "</string></value>" & _
        "</member>" & _
        "<member>" & _
            "<name>description</name>" & _
            "<value><string>" & description & "</string></value>" & _
        "</member>" & _
    "</struct>"
    
    
    'blogidは1できめうち
    param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
                "<methodCall>" & _
                    "<methodName>metaWeblog.newPost</methodName>" & _
                    "<params>" & _
                        "<param><value><int>1</int></value></param>" & _
                        "<param><value><string>" & mUserName & "</string></value></param>" & _
                         "<param><value><string>" & mPassword & "</string></value></param>" & _
                         "<param><value>" & contents & "</value></param>" & _
                         "<param><value><boolean>" & publish & "</boolean></value></param>" & _
                    "</params>" & _
                "</methodCall>"

    postToWP = callMethod(param)

End Function



'内部で使う、メソッドコール処理共通部分
Private Function callMethod(param As String)

  
    Dim response As String
    
    Set xhr = New XMLHTTP
    xhr.Open "POST", mURL, False
    xhr.setRequestHeader "Method", "POST " & mURL & " HTTP/1.1"
    xhr.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    

    On Error GoTo sendError
    xhr.send (param)

    response = xhr.responseText
    
    
    
    '
    '終了処理
    '
    Set xhr = Nothing

    
    callMethod = response
    
    Exit Function
    
    '
    'エラー処理
    '
sendError:
    MsgBox "送信エラー"
    callMethod = "error"

End Function