うん～～ まだ取り合えずつくってみましたか程度だな。日付にカレンダーフォームを使いたいし、エラーチェックなど入れたいな。まだまだこれからだなという顔をしている柴犬です。
概要
前回の投稿から、アフィリエイトの広告文を載せています。
ちょっと前から広告文をどのようにするか考えていましたが、書式などレイアウトを決めました。
ワードプレスに広告文を挿入する手間をなるべく簡単にしたいので、
１．フォームに画像のURL、文のURLをテキストボックスにコピー貼り付けする。
２．タイトル、詳細、現在日、ブラウザのボタンの表題はテキストボックスに入力する。
３．これらのデータからフォームのボタン「クリップボード」をクリックするとワードプレスに貼り付ける文書がクリップボードに作られる。
４．このクリップボードの文書をワードプレスのコードエディターで開いて希望のところに貼り付ける。
このようにすればかなりの長文の URL文でも取り扱いを省力化できます。
Delphi５ があるのでそれで作ろうかなと思いましたが、もう25年前のことで忘れていることも多いし、パスカルなので、 やはり手軽なのはEXCELです。
それで、EXCELでやってみたことを記事にしてみました。
作成できるのはこんな具合の広告文です。
フォーム
フォームのレイアウトは次のようになっています。
テキストボックスのオブジェクト名は、テキストボックスの文字としています。
プロパティ
プロパティは次のようにしています。MultiLine を True にします。
使用方法
各店舗の画像・テキストのURLをコピーして貼り付けます。
タイトル・詳細・店舗1～3のボタン表題、作成日を編集します。
フォームのボタン「クリップボード」をクリックして貼り付け文章をクリップボードにコピーします。
ワードプレスの貼り付け
ワードプレスのエディターをビジュアルコードエディターからコードエディターに変更します。
変更は、ワードプレス画面の右上の・が縦に3個並んだアイコンをクリックすると、メニューが表示されますので、コードエディターをクリックするだけです。
貼り付けたい位置（この場合四角の青色の位置）のにプロンプトを持っていきマウスの右クリック「貼り付け」またはキー 「Ctrl」 + 「V」 押下でクリップボードから貼り付けます。
これだけで終わりで、下の画面は貼り付け後です。
フォームのコード
メイン
＊＊＊＊＊動作せずのところは、他のホームページでも紹介されていますが、クリップボードにコピーされませんでした。
したがって、API関数で処理することにしました。
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の処理
'
'-----------------------------------------------------------------
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
見出し・第一店舗部分の処理
'
'-----------------------------------------------------------------
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
第二・第三店舗部分の処理
'
'-----------------------------------------------------------------
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名は黒塗りにしました。
'
'-----------------------------------------------------------------
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」にブラウザの表示部分を反映させます。
'
'-----------------------------------------------------------------
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型にすることです。
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型 しました。
本来は値をチェックしながら実行するようにするのでしょうが今回はそこまでする必要がないので、初めに確認できれば削除して原文のようにしてもいいのでしょう。