VBAで少しは役立つツール作成（Amazon商品URL短縮）

台風襲来で暇人

こういうの見るとついつい人間の性で顔に見えちゃうんだよなー

さて、AmazonのURLが長いので手作業で短縮してたが、最近URL教示が多くてめんどくさくなってた。
以前ならDelphiで作ったんだが今はインスコさえしていない。
せっかくVBAを毎年ボラで教えられてるんだからとツールを作ってみた。

こいつが
https://www.amazon.co.jp/dp/B07WTMXRTQ/
に短縮される。

アマゾンの製品URLをクリップボードへコピーしてExcelを起動する。
アマゾンのURLらしければ短縮してクリップボードへ書き込んで終わる
だけのもの。

Excelのフォームがどうしても見えてしまうがやむを得ないか。
そこまでの割り込みは表計算ユーザに渡されているとは思えないし。

－－－This workBookに記載－－－
Main()を呼んでいる

Option Explicit

Private Sub Workbook_Open()
  MsgBox "Copy to ClipBoard: " & main
  Application.Quit
End Sub

－－－－標準モジュールへ記載－－－－－
「This workBook」記載のVBAから呼ばれる

Option Explicit

Function main() As String
  Dim ws As String
  Dim ws2 As String
  main = ""
  ws = GetCB
  d ("clipBoard:" & ws)
  ws2 = unstAmaURL(ws)
  d ("Ans:" & ws2)
  SetCB (ws2)
  main = ws2
End Function

Public Sub SetCB(ByVal strSet As String)
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True '複数行入力可
        .Text = strSet
        .selstart = 0
        .sellength = .textlength
        .Copy
    End With
End Sub

'--------クリップボードの文字列を取得して返す-------------
Public Function GetCB() As String
    'MSForms.DataObjectを使用
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        .GetFromClipboard
        GetCB = .GetText
    End With
End Function

Function unstAmaURL(ws) As String
  Dim dEp As Long   ' ドメイン End Point
  Dim SP As Long    ' 商品コード　Start Point
  Dim EP As Long    ' 商品コード　End Point
  
  unstAmaURL = "ERR: Null Space"
  If ws = "" Then Exit Function
  unstAmaURL = "ERR: not URL"
  
  If UCase(Left(ws, 8)) <> "HTTPS://" Then Exit Function
  
  unstAmaURL = "ERR: /dp not found"
  '--------- ドメイン名を取得 ----------
  dEp = InStr(10, ws, "/")
  d ("dEp" & dEp)
  
  '------/DP/以下を取得--------------
  SP = InStr(1, ws, "/dp", vbTextCompare)
  EP = InStr(SP + 4, ws, "/")
  
  If SP = 0 Then      ' カート内製品や購入履歴URLに対応
    SP = InStr(1, ws, "/gp/product", vbTextCompare)
    EP = InStr(SP + 12, ws, "/")
  End If
  
  If SP = 0 Then Exit Function
  d ("sp:" & SP)
  d ("ep" & EP)
  
  unstAmaURL = Left(ws, dEp) & Mid(ws, SP + 1, (EP - SP))
  
End Function

Sub d(ws)
 Debug.Print (ws)
End Sub