ライフ

ExcelVBAでWordPressへの自動投稿をする方法

ExcelVBAでWordPressへの自動投稿をする方法

毎日の記事更新、WordPressへ自動投稿ができれば…と考えている方々は多くいるのではないでしょうか。

この記事を読めばWindows搭載PCで標準搭載されているExcelで自動投稿ソフトを作成することが可能です。

※もし自作するのが面倒な方は記事の最後でツールの販売も行っておりますのでご活用ください。

VBAの魅力はExcelを持っていれば、開発環境の準備など一切せずにプログラミングができること!

プログラミング経験がない方やパソコン操作が苦手な方も是非この記事を読んでVBAを始めてみてください。

ただし、総量がかなり大きくなるためいくつかの記事に分割させていただきます!

モジュールの構成

モジュール単位でやコードを説明していきます。

標準モジュール

Base64エンコーダー

モジュール名:Base64DecodeAndEncode.bas

ローカルのImageファイルをWordPressに自動投稿する際必要となるBase64へのエンコードを行うモジュールです。

Base64エンコーダー

プロシージャ名:EncodeBase64

引数の文字列をBase64エンコードし、エンコードした文字列を返却するプロシージャです。


Public Function EncodeBase64(ByVal FilePath As String) As String

Dim elm As Object
Dim ret As String
Const adTypeBinary = 1
Const adReadAll = -1

ret = "" 
On Error Resume Next
Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64")
With CreateObject("ADODB.Stream")
.Type = adTypeBinary
.Open
.LoadFromFile FilePath
elm.DataType = "bin.base64"
elm.nodeTypedValue = .Read(adReadAll)
ret = elm.Text
.Close
End With
On Error GoTo 0
EncodeBase64 = ret
End Function

カテゴリー操作

モジュール名:Category

カテゴリーの追加や記事のカテゴリーを設定するためのモジュールです。

カテゴリー追加

プロシージャ名:gsubAddCategory

投稿時に設定したいカテゴリーがWordPressのカテゴリーに設定されていない場合にカテゴリーを新しく追加するモジュールです。

Public Sub gsubAddCategory(sUser As String, sPass As String, sUrl As String, sCategory As String)
    Dim param As String
    Dim struct As String
    
    If gsubCheckCategoryExist(sCategory) = False Then
        struct = "<struct>" & _
        "<member>" & _
        "<name>name</name>" & _
        "<value><string>" & sCategory & "</string></value>" & _
        "</member>" & _
        "<member>" & _
        "<name>slag</name>" & _
        "<value><string>" & sCategory & "</string></value>" & _
        "</member>" & _
        "<member>" & _
        "<name>parent_id</name>" & _
        "<value><string>0</string></value>" & _
        "</member>" & _
        "<member>" & _
        "<name>description</name>" & _
        "<value><string></string></value>" & _
        "</member>" & _
        "</struct>"
        
        param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
        "<methodCall>" & _
        "<methodName>wp.newCategory</methodName>" & _
        "<params>" & _
        "<param><value><string>1</string></value></param>" & _
        "<param><value><string>" & sUser & "</string></value></param>" & _
        "<param><value><string>" & sPass & "</string></value></param>" & _
        "<param><value>" & struct & "</value></param>" & _
        "</params>" & _
        "</methodCall>"
    
        Sheets("category").Range("a1") = callMethod(param, sUrl & "/xmlrpc.php")
    End If

End Sub
カテゴリー設定

プロシージャ名:gsubGetCategory

投稿する記事のカテゴリーを設定するためのプロシージャです。

Public Sub gsubGetCategory(sUser As String, sPass As String, sUrl As String)

    Dim param As String
    Dim struct As String
        
    param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
    "<methodCall>" & _
    "<methodName>wp.getCategories</methodName>" & _
    "<params>" & _
    "<param><value><string>1</string></value></param>" & _
    "<param><value><string>" & sUser & "</string></value></param>" & _
    "<param><value><string>" & sPass & "</string></value></param>" & _
    "</params>" & _
    "</methodCall>"

    Sheets("re_category").Range("a1") = callMethod(param, sUrl & "/xmlrpc.php")

End Sub
カテゴリーの存在チェック

プロシージャ名:gsubCheckCategoryExist

カテゴリーが存在するかどうかをチェックするプロシージャ

Public Function gsubCheckCategoryExist(sCategory As String) As Boolean
    Dim sSearch As String
    Dim sTarget As String
    Dim sResult As String
    Dim bResult As Boolean
    
    bResult = False
    
    sSearch = "<member><name>categoryName</name><value><string>"
    sTarget = ThisWorkbook.Sheets("re_category").Range("a1").Value
    
    Do While InStr(sTarget, sSearch) > 0
        
        sTarget = Right(sTarget, Len(sTarget) - InStr(sTarget, sSearch) - Len(sSearch) + 1)
         sResult = Left(sTarget, InStr(sTarget, "<") - 1)
        If sResult = sCategory Then
            bResult = True
  
            Exit Do
        End If
    Loop
        
        
    gsubCheckCategoryExist = bResult

End Function
メソッドコール処理共通部分

プロシージャ名: callMethod

カテゴリーとはまったく関係ないですがここに記述します。

理由は後程…

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 "ERR!"
 callMethod = "error"
 
End Function

削除全般処理

モジュール名:Delete

記事やログの削除を行うモジュールです。

ログ削除

モジュール名:DeleteReport

ログを削除します。

Public Sub DeleteReport()
    
    Dim sPost As String
    Dim sUser As String
    Dim sPass As String
    Dim sUrl As String
    Dim sPost_Disp As String
    Dim lCount As Long
    sPost_Disp = ""
    
    Sheets("log_delete").Range("a1").Clear
    
    If Dir(ThisWorkbook.Path & "\log.xlsx") <> "" Then
        
        If Range("delCount").Value <> "" And Range("delCount").Value >= 1 Then
        
            For lCount = 1 To Range("delCount").Value
            
                Call SendLog.gsubGetLogData_Delete(sPost, sUser, sPass, sUrl)
                
                If mfncCheckParam(sPost, sUser, sPass, sUrl) = True Then
                    Dim param As String
                    Dim contents As String, categoriesTag As String, escaped As String
                    Dim categoryArray As Variant
                    Dim i As Integer
                     
                    param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
                    "<methodCall>" & _
                    "<methodName>blogger.deletePost</methodName>" & _
                    "<params>" & _
                    "<param><value><string>1</string></value></param>" & _
                    "<param><value><string>" & sPost & "</string></value></param>" & _
                    "<param><value><string>" & sUser & "</string></value></param>" & _
                    "<param><value><string>" & sPass & "</string></value></param>" & _
                    "<param><value>content</value></param>" & _
                    "<param><value><boolean>1</boolean></value></param>" & _
                    "</params>" & _
                    "</methodCall>"
                
                    Sheets("log_delete").Range("a1") = callMethod(param, sUrl & "/xmlrpc.php")
                    
                    sPost_Disp = sPost_Disp & sPost & ";"
                    
                Else
                    MsgBox lCount & " is noLog " & Chr(13) & "You should find LOGFILE"
                End If
            Next
            If sPost_Disp <> "" Then
                sPost_Disp = Left(sPost_Disp, Len(sPost_Disp) - 1)
                MsgBox "POSTID : " & sPost_Disp & "Delete"
            End If
        Else
        
            MsgBox "Input more 1Char"
            
        End If
        
    Else
        MsgBox "[log.xlsx] put directry own this file"
    
    End If
 
End Sub
記事削除(POSTID指定)

プロシージャ名:DeleteReport_PostID

ポストIDを指定して記事を削除します。

Public Sub DeleteReport_PostID()
    
    Dim sPost As String
    Dim sUser As String
    Dim sPass As String
    Dim sUrl As String
    
    Sheets("log_delete").Range("a1").Clear
    
    sPost = Range("??PostID").Value
    sUser = Range("???A?J?E???g").Value
    sPass = Range("???p?X???[?h").Value
    sUrl = Range("??URL").Value
    
    Dim param As String
    Dim contents As String, categoriesTag As String, escaped As String
    Dim categoryArray As Variant
    Dim i As Integer
     
    param = "<?xml version='1.0' encoding='utf-8'?>" & vbNewLine & _
    "<methodCall>" & _
    "<methodName>blogger.deletePost</methodName>" & _
    "<params>" & _
    "<param><value><string>1</string></value></param>" & _
    "<param><value><string>" & sPost & "</string></value></param>" & _
    "<param><value><string>" & sUser & "</string></value></param>" & _
    "<param><value><string>" & sPass & "</string></value></param>" & _
    "<param><value>content</value></param>" & _
    "<param><value><boolean>1</boolean></value></param>" & _
    "</params>" & _
    "</methodCall>"
    
    Sheets("log_delete").Range("a1") = callMethod(param, sUrl & "/xmlrpc.php")
 
End Sub

メソッドコール共通処理

プロシージャ名:callMethod

ここでも共通処理を記述します。

理由は後程…

Private Function callMethod(param As String, mUrl 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 "ERR!!"
    callMethod = "error"
 
End Function

引数チェック

プロシージャ名:mfncCheckParam

パラメータがブランクの場合エラーとして処理します。

Private Function mfncCheckParam(A As String, B As String, C As String, D As String) As Boolean
    Dim bResult As Boolean
    bResult = True
    
    If A = "" Then
        bResult = False
    End If
    If B = "" Then
        bResult = False
    End If
    If C = "" Then
        bResult = False
    End If
    If D = "" Then
        bResult = False
    End If
    If D = "URL" Then
        bResult = False
    End If
    
    mfncCheckParam = bResult
End Function

製品版の販売

ココナラにて製品版を販売しております。

製品版の購入はこちらから

-ライフ
-, , ,

© 2023 たくあん Powered by AFFINGER5