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
製品版の販売
ココナラにて製品版を販売しております。