Sibainu Relax Room

愛犬の柴犬とともに過ごす部屋

アフィリエイトの挿入コードを作成するアプリをエクセルで作成

うん～～　まだ取り合えずつくってみましたか程度だな。日付にカレンダーフォームを使いたいし、エラーチェックなど入れたいな。まだまだこれからだなという顔をしている柴犬です。

概要

前回の投稿から、アフィリエイトの広告文を載せています。

ちょっと前から広告文をどのようにするか考えていましたが、書式などレイアウトを決めました。

ワードプレスに広告文を挿入する手間をなるべく簡単にしたいので、

１．フォームに画像のURL、文のURLをテキストボックスにコピー貼り付けする。

２．タイトル、詳細、現在日、ブラウザのボタンの表題はテキストボックスに入力する。

３．これらのデータからフォームのボタン「クリップボード」をクリックするとワードプレスに貼り付ける文書がクリップボードに作られる。

４．このクリップボードの文書をワードプレスのコードエディターで開いて希望のところに貼り付ける。

このようにすればかなりの長文の URL文でも取り扱いを省力化できます。

Delphi５ があるのでそれで作ろうかなと思いましたが、もう25年前のことで忘れていることも多いし、パスカルなので、 やはり手軽なのはEXCELです。

それで、EXCELでやってみたことを記事にしてみました。

作成できるのはこんな具合の広告文です。

ゲームで学ぶ探索アルゴリズム実践入門～木探索とメタヒューリスティクス
技術評論社出版・著者青木栄太氏

2023年4月20日現在

フォーム

フォームのレイアウトは次のようになっています。

テキストボックスのオブジェクト名は、テキストボックスの文字としています。

プロパティ

プロパティは次のようにしています。MultiLine を True にします。

使用方法

各店舗の画像・テキストのURLをコピーして貼り付けます。

タイトル・詳細・店舗1～3のボタン表題、作成日を編集します。

フォームのボタン「クリップボード」をクリックして貼り付け文章をクリップボードにコピーします。

ワードプレスの貼り付け

ワードプレスのエディターをビジュアルコードエディターからコードエディターに変更します。

変更は、ワードプレス画面の右上の・が縦に3個並んだアイコンをクリックすると、メニューが表示されますので、コードエディターをクリックするだけです。

貼り付けたい位置（この場合四角の青色の位置）のにプロンプトを持っていきマウスの右クリック「貼り付け」またはキー 「Ctrl」 + 「V」 押下でクリップボードから貼り付けます。

これだけで終わりで、下の画面は貼り付け後です。

フォームのコード

メイン

＊＊＊＊＊動作せずのところは、他のホームページでも紹介されていますが、クリップボードにコピーされませんでした。

したがって、API関数で処理することにしました。

copy

Option Explicit

Private myText As String
'
'-----------------------------------------------------------------
Private Sub クリップボード_Click()

    myText = ""
   
    Call makemyText

    Call setPicturURL

    Call setTopURL

    Call setRakutenURL

    Call setAmazonURL

    If myText <> "" Then

        myText = Replace(myText, "#DetailText#", Me.DetailText.Value)
        myText = Replace(myText, "#MakeDate#", Me.MakeDate.value)


        Call SetClipboard(myText)

        '＊＊＊＊＊動作せず
        'With New DataObject
        '    .SetText myText
        '    .PutInClipboard
        'End With
    Else
        MsgBox "データを作成できませんでした。"
    End If
    
End Sub
'
'-----------------------------------------------------------------
Private Sub 閉じる_Click()

    Unload Me

End Sub

画像URLの処理

copy

'
'-----------------------------------------------------------------
Private Sub setPicturURL()
    Dim buf             As String

    buf = Me.PictureURL.Value

    If InStr(buf, "<a href") > 0 And _
       InStr(buf, "</a>") > 0 And _
       InStr(buf, "<img") > 0 Then
        myText = Replace(myText, "#PictureURL#", buf)
    Else
        myText = ""
    End If

End Sub

見出し・第一店舗部分の処理

copy

'
'-----------------------------------------------------------------
Private Sub setTopURL()

    Call changeURL("#TopURL#", Me.TopURL.Value, Me.TopCaption.Value)

End Sub
'
'-----------------------------------------------------------------
Private Sub setRakutenURL()

    Call changeURL("#RakutenURL#", Me.RakutenURL.Value, Me.RakutenCaption.Value)

End Sub
'
'-----------------------------------------------------------------
Private Sub changeURL(inv As String, url As String, cap As String)
    Dim res             As String
    Dim s               As String

    If InStr(url, "<a href=") = 1 And Right(url, 4) = "</a>" Then
        s = InStr(url, ">")
        If s = InStrRev(url, ">", Len(url) - 1) Then
            res = Left(url, s) & cap & "</a>"
            res = Replace(res, "<a ", "<a style=""word-wrap: break-word;"" ")
        End If
    End If

    If res <> "" Then
        myText = Replace(myText, inv, res)
    Else
        myText = ""
    End If

End Sub

第二・第三店舗部分の処理

copy

'
'-----------------------------------------------------------------
Private Sub setAmazonURL()

    Call changeAmazonURL("#AmazonURL#", Me.AmazonURL.Value)

    Call changeAmazonURL("#AmazonCaption#", Me.AmazonCaption.Value)

    Call changeAmazonURL("#KindleURL#", Me.KindleURL.Value)

    Call changeAmazonURL("#KindleCaption#", Me.KindleCaption.Value)

End Sub
'
'-----------------------------------------------------------------
Private Sub changeAmazonURL(inv As String, urlcap As String)
    Dim res             As String

    If InStr(inv, "URL") > 0 Then
        If InStr(urlcap, "<a href=") = 0 And _
           InStr(urlcap, "</a>") = 0 Then
            res = urlcap
        End If
    Else
        res = urlcap
    End If

    If res <> "" Then
        myText = Replace(myText, inv, urlcap)
    Else
        myText = ""
    End If

End Sub

加工する基本文

ワードプレスに挿入するHTML文も置き換える文の一塊を一文に置き換えると簡潔な文になります。

#PictureURL# #TopURL# #DetailText# #MakeDate# #RakutenURL# #AmazonURL# #AmazonCaption# #KindleURL# #KindleCaption# という具合に#で囲んでこれを単位としてHTML文の中での位置決めをしてます。

この単位文を目的の URL文、ブラウザのボタンの表題、タイトル、作成日などを入れ替える作業をします。

class名は黒塗りにしました。

copy

'
'-----------------------------------------------------------------
Private Sub makemyText()

    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "#PictureURL#" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "#TopURL#" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "<div class=""■■■■■"">#DetailText#</div>" & Chr(10)
    myText = myText & "<p class=""■■■■■"">#MakeDate#</p>" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "#RakutenURL#" & Chr(10)
    myText = myText & "</div>"
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "<a href=""#AmazonURL#"">#AmazonCaption#</a>" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "<div class=""■■■■■"">" & Chr(10)
    myText = myText & "<a href=""#KindleURL#"">#KindleCaption#</a>" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "</div>" & Chr(10)
    myText = myText & "</div>"


End Sub

URL文を貼り付けたときの処理

テキストボックス「TopUR」「RakutenURL」にURL文を貼り付けたときテキストボックス「TopCaption」「RakutenCaption」にブラウザの表示部分を反映させます。

copy

'
'-----------------------------------------------------------------
Private Sub TopURL_Change()

    Call setCaption(Me.TopURL.Text, "TopCaption")

End Sub
'
'-----------------------------------------------------------------
Private Sub RakutenURL_Change()

    Call setCaption(Me.RakutenURL.Text, "RakutenCaption")

End Sub
'
'-----------------------------------------------------------------
Private Sub setCaption(inputStr As String, setCtrl As String)
    Dim s               As String
    Dim res             As String

    If InStr(inputStr, "<a href=") > 0 And _
       InStr(inputStr, "</a>") > 0 Then
        s = InStr(inputStr, ">")
        If s = InStrRev(inputStr, ">", Len(inputStr) - 1) Then
            res = Mid(inputStr, s + 1)
            res = Left(res, InStr(res, "<") - 1)
        End If
    End If

    Me(setCtrl).Value = res

End Sub

標準モジュールのコード

Microsoft の次のホームページの「クリップボードに情報を送信する　Windows API を使用する」からのコードを使います。

https://learn.microsoft.com/ja-jp/office/vba/access/concepts/windows-api/send-information-to-the-clipboard

そのままのコードでは 64bit Windows では動作しませんので次のように修正しました。その修正は、hMem は Long型ではだめでLongPtr型にして、それに合わせて他も Long型から LongPtr型にすることです。

copy

Option Explicit
'
'-----------------------------------------------------------------
#If VBA7 And Win64 Then

    Private Declare PtrSafe Function OpenClipboard _
        Lib "user32.dll" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard _
        Lib "user32.dll" () As Long
    Private Declare PtrSafe Function CloseClipboard _
        Lib "user32.dll" () As Long
    Private Declare PtrSafe Function IsClipboardFormatAvailable _
        Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function GetClipboardData _
        Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare PtrSafe Function SetClipboardData _
        Lib "user32.dll" (ByVal wFormat As Long, _
                          ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalAlloc _
        Lib "kernel32.dll" (ByVal wFlags As Long, _
                            ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock _
        Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock _
        Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function GlobalSize _
        Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy _
        Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, _
                                             ByVal lpString2 As LongPtr) As Long

#Else

    Private Declare Function OpenClipboard _
        Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function EmptyClipboard _
        Lib "user32.dll" () As Long
    Private Declare Function CloseClipboard _
        Lib "user32.dll" () As Long
    Private Declare Function IsClipboardFormatAvailable _
        Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipboardData Lib _
        "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare Function SetClipboardData Lib _
        "user32.dll" (ByVal wFormat As Long, _
                      ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib _
        "kernel32.dll" (ByVal wFlags As Long, _
                        ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock _
        Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock _
        Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize _
        Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function lstrcpy _
        Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, _
                                             ByVal lpString2 As Long) As Long
    
#End If
'
'-----------------------------------------------------------------
Const GMEM_MOVEABLE As Long = &H2
Const GMEM_ZEROINIT As Long = &H40
Const CF_UNICODETEXT As Long = &HD
'
'-----------------------------------------------------------------
Public Sub SetClipboard(sUniText As String)
    Dim iStrPtr As LongPtr
    Dim iLen As Long
    Dim iLock As LongPtr
    Dim res As Long

    res = OpenClipboard(0&)

    res = EmptyClipboard

    iLen = LenB(sUniText) + 2&

    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)

    iLock = GlobalLock(iStrPtr)

    res = lstrcpy(iLock, StrPtr(sUniText))

    res = GlobalUnlock(iStrPtr)

    res = SetClipboardData(CF_UNICODETEXT, iStrPtr)

    res = CloseClipboard

End Sub
'なぜか iLock iLen が取得できない。原因不明。
'取得できるようになれば、この GetClipboard を使ってもっと省力化できる。
'-----------------------------------------------------------------
Public Function GetClipboard() As String
    Dim iStrPtr As LongPtr
    Dim iLen As Long
    Dim iLock As LongPtr
    Dim sUniText As String
    Dim res As Long

    Const CF_UNICODETEXT As Long = 13&

    res = OpenClipboard(0&)

    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then

        iStrPtr = GetClipboardData(CF_UNICODETEXT)

        If iStrPtr Then

            'なぜか 0
            iLock = GlobalLock(iStrPtr)
            'なぜか 0
            iLen = GlobalSize(iStrPtr)

            'iLen が 0 だと致命的エラー　再起動が必要
            If iLen > 1 Then
                sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            Else
                sUniText = String$(0, vbNullChar)
            End If

            res = lstrcpy(StrPtr(sUniText), iLock)

            res = GlobalUnlock(iStrPtr)

        End If

        GetClipboard = sUniText

    End If

    res = CloseClipboard

End Function

関数「SetClipboard」「GetClipboard」の中で、原文にはない変数 res で値を受け取っています。

それぞれのAPI関数は実行でエラーになると 0 を返しますので、変数 res の値は 0 になります。

原文のままではエラーになりましたので、変数 res で受けてどこで変数res が 0 になるのか確認し、Long型 を LongPtr型 しました。

本来は値をチェックしながら実行するようにするのでしょうが今回はそこまでする必要がないので、初めに確認できれば削除して原文のようにしてもいいのでしょう。