Googleドライブにある画像の直リンクをクリップボードにコピーする

前回の、Googleドライブにある画像の直リンク取得だが、
使用回数重ねるうちに思ったのは、いちいちダイアログからコピーするのが
億劫だってこと。

修正自体はリザルト先を入力ダイアログからクリップボード
変えるだけだし一先ず直してみる。
とは言え、これで使い易くなるのかどうかピンと来ないんだけども…。

尚、VBSでクリップボードへのコピーはここを参考にした。

clipコマンドを利用してクリップボードに文字列をコピーするVBScript | 初心者備忘録

動作はclipコマンドを使い実現しているので、
扱う文字列にコマンドプロンプトのエスケープ文字「 "|<>&」が
入り込まないことが約束されている場合のみ取り入れると良さ気。

仮にエスケープ文字を含む文字列をクリップボードにコピーしたいなら、
InternetExplorerオブジェクトを使ったこちらの解説が役立つだろう
(ソース見ると分かるが、力技なアプローチ。)。

クリップボードに文字列をコピーする | 初心者備忘録


●操作手順

1.Googleドライブにある画像を右クリック
2.「共有可能なリンクを取得」から表示されるリンクを選択してCtrl+Cでコピー
3.VBSを実行して直リンクをクリップボードへセット
4.クリップボードにコピーされた直リンクを貼り付ける等して使用


GoogleDriveCreatePermalink.vbs

Option Explicit

Const TITLE = "Googleドライブ画像、直リンク生成"
Const VERSION = "Ver1.10"
Const RELEASE = #2017/04/30#
Const AUTHOR = "REGEKATSU"

'元URL
Const SEARCH_TEXT = "https://drive.google.com/open?id="
'加工URL
Const REPLACE_TEXT = "https://drive.google.com/uc?id="
'完了メッセージ表示時間(秒)
Const WAIT_TIME = 5

Dim clipText
Dim putText

'クリップボードのテキストデータを確認する
clipText = GetClipboardText()

'クリップボードが空なら終了する
If IsNull(clipText) Then
    WScript.Echo "貼り付けるデータがありません。" & vbCrLf & _
        "とりあえず、何かコピーしてください。。。"
    WScript.Quit
    
'クリップボードに共有リンクが含まれていなければ終了する
ElseIf InStr(clipText, SEARCH_TEXT) <= 0 Then
    WScript.Echo "貼り付けるデータが正しくありません。" & vbCrLf & _
        "共有可能なリンクを取得からコピーしてください。。。"
    WScript.Quit
    
End If

'Googleドライブ内画像の共有可能なリンクから直リンクを生成する
putText = Replace(clipText, SEARCH_TEXT, REPLACE_TEXT)

'クリップボードへテキストデータをセットする
SetClipboardText putText

'完了メッセージを一定時間表示する
CreateObject("WScript.Shell").Run _
    "cmd /c echo " & TITLE & " " & VERSION & " & " & _
    "echo 共有可能なリンクから直リンクを生成しました。 & " & _
    "echo 直リンク: " & putText & " & " & _
    "echo; & " & _
    "echo ※この画面は " & WAIT_TIME & " 秒後に閉じます... & " & _
    "ping -n " & WAIT_TIME & " localhost > nul", 1

WScript.Quit


'サブルーチン

'クリップボードのテキストデータを取得する。なければNullを返す。
Function GetClipboardText()
    Dim objHTML
    Set objHTML = CreateObject("htmlfile")
    GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
    Set objHTML = Nothing
End Function

'クリップボードへテキストデータをセットする。
Sub SetClipboardText(ByVal str)
    Dim cmd
    cmd = "cmd /c ""echo " & str & "| clip"""
    CreateObject("WScript.Shell").Run cmd, 0, True
End Sub

Googleドライブにある画像の直リンクを生成する

Googleドライブに保存した画像から、
「共有可能なリンクを取得」でURLが得られるのだが
どうもGoogleの画像ビューア経由で表示されてしまい、
HTMLのIMGタグで指定することが出来なかった。

少し調べてみたところURLを加工することで直リンクもイケるらしい。

Google Driveに入れた画像を直接表示するパスを取得する。 - 亀岡的プログラマ日記

1枚2枚なら解説のとおり手作業でも問題無いんだが、
それ以上数をこなしてくとなると結構な手間になるのは目に見えているので、
加工を行うVBSを作ってみた。

VBSでクリップボードのテキスト取得はここら辺を参考にした。

VBScript でクリップボードのデータを扱う


●操作手順

1.Googleドライブにある画像を右クリック
2.「共有可能なリンクを取得」から表示されるリンクを選択してCtrl+Cでコピー
3.VBSを実行して直リンクを表示
4.表示された直リンクをコピー等して使用


GoogleDriveCreatePermalink.vbs

Option Explicit

Const TITLE = "Googleドライブ内画像 パーマリンク生成"
Const VERSION = "Ver1.00"
Const RELEASE = #2017/04/17#
Const AUTHOR = "DumBo"

Const SEARCH_TEXT = "https://drive.google.com/open?id="
Const REPLACE_TEXT = "https://drive.google.com/uc?export=view&id="

Dim clipText
Dim putText

'クリップボードのテキストデータ確認
clipText = GetClipboardText()

'クリップボードが空なら終了する
If IsNull(clipText) Then
    WScript.Echo "貼り付けるデータがありません。" & vbCrLf & _
        "とりあえず、何かコピーしてください。。。"
    WScript.Quit
    
'クリップボードに共有リンクが含まれていなければ終了する
ElseIf InStr(clipText, SEARCH_TEXT) <= 0 Then
    WScript.Echo "貼り付けるデータが正しくありません。" & vbCrLf & _
        "共有可能なリンクを取得からコピーしてください。。。"
    WScript.Quit
    
End If

'Googleドライブ内画像の共有可能なリンクからパーマリンクを生成する
putText = Replace(clipText, SEARCH_TEXT, REPLACE_TEXT)

Call InputBox("共有可能なリンクからパーマリンクを生成しました。" & vbCrLf & _
    "テキストボックスからコピーして使用してください。", _
    TITLE & " " & VERSION, putText)

WScript.Quit


'サブルーチン

'クリップボードにあるテキストデータを取得する。なければNullを返す。
Function GetClipboardText()
    Dim objHTML
    Set objHTML = CreateObject("htmlfile")
    GetClipboardText = Trim(objHTML.ParentWindow.ClipboardData.GetData("text"))
    Set objHTML = Nothing
End Function

ImageMagickで画像をリサイズ&コンテキストメニューに追加

蔵書管理で使う本の表紙画像を長辺250ピクセルとしてリサイズする用途のもの。

スキャンしたり拾ってきたりした画像は大概求めるよりもサイズが大きくてね。

以前はIrFanViewを開いてはポチポチと縮小していたものだが、
ImageMagickならコマンドラインから呼び出せると聞いたので、
蔵書登録作業における部分最適化を試みたという次第。

リサイズルーチンは下記を参考に、やや追記加えた感じで使用中。

長辺の長さを一定にして画像を一括リサイズするbatを書いた - Qiita

同じディレクトリのpng画像を長辺900pxにリサイズするbatファイル(http://qiita.com/smison/items/d32eb72be807e099dfa0) · GitHub

バッチ本体を配置するドライブとかフォルダは任意で対応を任すところ。
※実行にはImageMagickのインストールが必要


ImageMagickで画像をリサイズ

resize.bat

@echo off
REM Image Magick - 画像を長辺に合わせてリサイズ
REM version 0.01.2
REM 2016/09/10
REM by.REGEKATSU

REM 変換後の長辺サイズを設定
set RESIZE=250

REM 画像名のサフィックスを設定
set SUFFIX=_resized

REM 出力画像形式オプション
REM 0=元と同じ画像形式, 1=全て指定した画像形式
set OUT_OPTION=1

REM 出力画像形式の指定
set OUT_EXT=.png

REM 引数の分だけ処理を実行
:loop
if "%~1"=="" goto end

REM 出力画像形式が元画像と同じ場合
if %OUT_OPTION%==0 set OUT_EXT=%~x1

REM 入力画像の拡張子を小文字に変換
set IN_EXT=%~x1
for %%i in (a b c d e f g h i j k l m n o p q r s t u v w x y z) do call set IN_EXT=%%IN_EXT:%%i=%%i%%

REM 入力が画像であるか確認
set IS_TRUE=FALSE
if %IN_EXT%==.bmp set IS_TRUE=TRUE
if %IN_EXT%==.tif set IS_TRUE=TRUE
if %IN_EXT%==.tiff set IS_TRUE=TRUE
if %IN_EXT%==.jpg set IS_TRUE=TRUE
if %IN_EXT%==.jpeg set IS_TRUE=TRUE
if %IN_EXT%==.gif set IS_TRUE=TRUE
if %IN_EXT%==.png set IS_TRUE=TRUE

if %IS_TRUE%==TRUE (
setlocal enabledelayedexpansion

  REM 画像の縦幅を取得
  for /f "usebackq tokens=*" %%i in (`identify -format '%%h' %1`) do @set HEIGHT=%%i

  REM 画像の横幅を取得
  for /f "usebackq tokens=*" %%i in (`identify -format '%%w' %1`) do @set WIDTH=%%i

  REM 幅情報に含まれる前後の「'」を除去
  @set WIDTH=!WIDTH:~1,-1!
  @set HEIGHT=!HEIGHT:~1,-1!

  if !HEIGHT! GEQ !WIDTH! (
    REM 縦幅>=横幅
    convert -resize x%RESIZE% %1 "%~dpn1%SUFFIX%%OUT_EXT%"
  ) else (
    REM 縦幅<横幅
    convert -resize %RESIZE%x %1 "%~dpn1%SUFFIX%%OUT_EXT%"
  )

REM 処理を行った画像情報を表示
echo %1%~n1%SUFFIX%%OUT_EXT%、長辺 %RESIZE%px にリサイズ
)

REM 次の引数へシフト
shift
goto loop

:end


コンテキストメニューに追加
レジストリはresize.batが以下パスにあるとした場合のもの
C:\regekatsu\utility\ImageMagick\resize.bat

ImageMagickで画像をリサイズ.reg

Windows Registry Editor Version 5.00

[HKEY_CLASSES_ROOT\*\shell]

[HKEY_CLASSES_ROOT\*\shell\imagemagickresize]
@="ImageMagickで画像をリサイズ(&I)"

[HKEY_CLASSES_ROOT\*\shell\imagemagickresize\command]
@="\"C:\\regekatsu\\utility\\ImageMagick\\resize.bat\" \"%1\""

ASIN/ISBNから商品ページ名を取得する

前に軽く触れた、ちょっとしたアマゾン用ツールというやつ。Amazon.co.jp用。
Kindle for PC でローカルに落としたKindle本でコレなんだったっけ?
と軽く調べるのに作成。

もっとちゃんとした類似ツールはどこかで見かけた気がする(失念)。


●概要

ASIN/ISBN(13桁または10桁)を引数で渡すか、
直接手入力することで、Webから商品ページ名を取ってくる。
CScriptで実行した場合の入出力にも対応しているので
バッチ処理に組み込むことも可能。
なお、ASIN/ISBNの指定は全半角問わず動作する。


●操作手順

GUIの場合(引数有り)

ASIN/ISBNを名前に含むファイルをVBSにドラッグドロップ。
ファイルは複数指定することが可能。
しばらくすると取得結果がダイアログに表示される。
(複数指定した場合、結果出力が以降も繰り返し表示される。)


CUIの場合(引数有り)

第1引数以降にASINまたはISBNを名前に含むファイル(フルパス)、
またはASIN(10桁)かISBN(10、13桁)の商品コードを指定して実行。
引数は複数指定することが可能。

CScript AmazonGetItemPageName.vbs [ファイル(フルパス)OR商品コード [ファイル(フルパス)OR商品コード] [...]]

しばらくすると取得結果が標準出力に表示される。
(複数指定した場合、結果出力が以降も繰り返し表示される。)


・引数無しの場合(GUICUI)

引数無しで実行した場合、
「ASIN/ISBN10桁またはISBN13桁を入力してください」という
プロンプトが表示されるので、ASIN/ISBNを入力して実行する。
しばらくすると取得結果がダイアログまたは標準出力に表示される。


●オプション設定

ソースの以下変数に対する値を変更することで
一部動作の変更が可能。

'IE表示設定(デフォルトは非表示)
'True=表示, False=非表示
Dim isIeVisible
isIeVisible = False

'結果出力設定(デフォルトは表示)
'True=表示, False=非表示
Dim isPutResult
isPutResult = True


●既知の問題

Q1.1件取得までの時間が長い
A1.Amazon商品ページが重く、取得完了までしばらく掛かる為

Q2.JANコードでの取得結果が正しくない
A2.ASIN、ISBN-10、ISBN-13何れかのコードのみ対応

Q3.購入履歴や、コンテンツと端末の管理から再ダウンロード出来る商品が
   正しく取得されない
A3.Amazonで販売終了している商品は404 Not Foundページ情報が帰る
   例):出版社が販売を終了したKindle本、期間限定無料のKindle本など


●実装について

要件が大したことなかったので、
ieオブジェクトからのスクレイピングでちゃちゃっと取得。
Amazon検索フォームを使わず存在し得るURLを生成、リクエストしている。
JANコードでの指定が不可なのはその為。

詳細な情報取るならAmazonAPIで取って来たXMLパースするのが最善だけど
さっさと作って使いたい場合には向いてないかなと。
(.net以前のVBだとリクエスト作るのに結構追加実装が必要だったり、
動かすのにもアソシエイトキー他諸々が必要だったりするし。)


AmazonGetItemTitle.vbs

Option Explicit

'ASCII <-> Shift_JIS 文字コード変換補数
Const SHIFT_CODE = &H7DE1

'バーション情報定数
Const APP_NAME = "AmazonGetItemTitle"
Const APP_VERSION = "Ver1.10"
Const APP_RELEASE = #2017/04/26#
Const APP_AUTHOR = "REGEKATSU"

'Amazon情報定数
Const PROTOCOL = "https"
Const DOMAIN = "www.amazon.co.jp"
Const TITLE_AGE_AUTH = "アダルトコンテンツ"
Const VERIFY_TOKEN = "はい"

'Amazon商品コード形式定数
Const CODE_UNKNOWN = -1
Const CODE_ASIN = 0
Const CODE_ISBN10 = 1
Const CODE_ISBN13 = 2

'実行中インタプリタ定数
Const RUNNING_UNKNOWN = -1
Const RUNNING_CSCRIPT = 0
Const RUNNING_WSCRIPT = 1

'IE表示設定(デフォルトは非表示)
'True=表示, False=非表示
Dim isIeVisible
isIeVisible = False

'結果出力設定(デフォルトは表示)
'True=表示, False=非表示
Dim isPutResult
isPutResult = True

Dim temp
Dim code

Dim index
Dim param
Set param = WScript.Arguments

'引数指定があった場合
For index = 0 To param.Count - 1
    temp = param(index)
    code = ""
    temp = StrConvNarrow(temp)
    
    'ファイル/フォルダ渡し(ASIN/ISBNを名前に含むファイル/フォルダ)
    If InStr(temp, "\") > 0 Then
        temp = Mid(temp, InStrRev(temp, "\") + 1)
        code = GetAsinOrIsbn(temp)
        
        '文字列渡し(ASIN/ISBN-10またはISBN-13を含む文字列)
    ElseIf Len(temp) >= 10 Then
        code = GetAsinOrIsbn(temp)
        
    End If
    
    If code <> "" Then
        'ISBN-10/ISBN-13だった場合、ISBN-10に変換または再計算する
        code = CalcIsbn10(code)
        'Amazon.co.jp商品ページから商品名を取得する
        GetItemTitle code, isIeVisible, isPutResult
    End If
Next

'引数指定がなかった場合
If param.Count <= 0 Then
    'ASIN/ISBNの入力を求める
    Dim prompt
    prompt = "ASIN/ISBN10桁またはISBN13桁を入力してください"
    If CheckRunningScript = RUNNING_CSCRIPT Then
        WScript.Echo APP_NAME & " " & APP_VERSION & vbCrLf & prompt
        temp = WScript.StdIn.ReadLine
    Else
        temp = InputBox(prompt, APP_NAME & " " & APP_VERSION)
    End If
    temp = StrConvNarrow(temp)
    
    '文字列渡し(ASIN/ISBN-10またはISBN-13)
    If Len(temp) = 10 Or Len(temp) = 13 Then
        code = GetAsinOrIsbn(temp)
    End If
    
    If code <> "" Then
        'ISBN-10/ISBN-13だった場合、ISBN-10に変換または再計算する
        code = CalcIsbn10(code)
        'Amazon.co.jp商品ページから商品名を取得する
        GetItemTitle code, isIeVisible, isPutResult
    Else
        '入力キャンセルした場合、処理を中断する
        WScript.Echo "処理を中断します。"
    End If
End If

Set param = Nothing

WScript.Quit


'サブルーチン

'指定したISBN-10/ISBN-13を元に計算後ISBN-10を返す
'指定した文字列がISBN-10/ISBN-13でなければ、そのままの文字列を返す
Function CalcIsbn10(isbn10_13)
    Dim code
    code = isbn10_13
    If CheckAsinOrIsbn(code) = CODE_ISBN13 Then
        'ISBN-13だった場合、ISBN-10に変換
        code = Isbn13ToIsbn10(code)
    ElseIf CheckAsinOrIsbn(code) = CODE_ISBN10 Then
        'ISBN-10だった場合、ISBN-10を再計算
        code = Isbn13ToIsbn10("978" & code)
    End If
    CalcIsbn10 = code
End Function

'指定した文字列にASIN/ISBNが含まれていれば該当文字列を返し、そうでなければ空文字を返す。
Function GetAsinOrIsbn(str)
    Dim code
    code = ""
    Dim RE, reMatch
    Set RE = CreateObject("VBScript.RegExp")
    With RE
        '文字列にISBN-13が含まれているか確認
        .Pattern = "[0-9]{13}"
        Set reMatch = .Execute(str)
        If reMatch.Count > 0 Then
            code = reMatch(0).Value
        Else
            Set reMatch = Nothing
            '文字列にASINまたはISBN-10が含まれているか確認
            .Pattern = "[0-9a-zA-Z]{10}"
            Set reMatch = .Execute(str)
            If reMatch.Count > 0 Then
                code = reMatch(0).Value
            End If
        End If
        Set reMatch = Nothing
    End With
    GetAsinOrIsbn = UCase(code)
    Set RE = Nothing
End Function

'指定した文字列にあるASIN/ISBNより商品コード形式を返す
'商品コード形式: CODE_UNKNOWN=-1, CODE_ASIN=0, CODE_ISBN10=1, CODE_ISBN13=2
Function CheckAsinOrIsbn(str)
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    
    '文字列にISBN-13が含まれているか確認
    RE.Pattern = "[0-9]{13}"
    If RE.Test(str) Then
        CheckAsinOrIsbn = CODE_ISBN13
        Set RE = Nothing
        Exit Function
    End If
    
    '文字列にISBN-10が含まれているか確認
    RE.Pattern = "[0-9]{9}[0-9xX]{1}"
    If RE.Test(str) Then
        CheckAsinOrIsbn = CODE_ISBN10
        Set RE = Nothing
        Exit Function
    End If
    
    '文字列にASINが含まれているか確認
    RE.Pattern = "[0-9a-zA-Z]{10}"
    If RE.Test(str) Then
        CheckAsinOrIsbn = CODE_ASIN
        Set RE = Nothing
        Exit Function
    End If
    
    '文字列にASINまたはISBNが含まれていなかった場合
    CheckAsinOrIsbn = CODE_UNKNOWN
    Set RE = Nothing
End Function

'指定したISBN13桁またはチェックディジットを含まない12桁からISBN-10を返す
'指定した文字列に誤りがあった場合は空文字を返す
Function Isbn13ToIsbn10(isbn12_13)
    '指定した文字列が数字12桁または13桁の文字列であるか確認
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^[0-9]{12,13}$"
    RE.Global = True
    
    '指定した文字列に誤りがあった場合は空文字を返す
    If Not RE.Test(isbn12_13) Then
        Isbn13ToIsbn10 = ""
        Set RE = Nothing
        Exit Function
    End If
    Set RE = Nothing
    
    'ISBN13桁またはチェックディジットを含まない12桁からISBN-10を返す
    Dim isbn9
    Dim checkDigit
    isbn9 = Mid(isbn12_13, 4, 9)
    checkDigit = CalcCheckDigit11_10_2(isbn9)
    Isbn13ToIsbn10 = isbn9 & checkDigit
End Function

'指定した数字9桁か10桁、または10桁目が「X」の文字列に対するチェックディジットを返す
'(モジュラス11 ウェイト10-2)。
'指定した文字列に誤りがあった場合は空文字を返す
Function CalcCheckDigit11_10_2(isbn9_10)
    '指定した文字列が数字9桁か10桁、10桁目が「X」の文字列であるか確認
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^([0-9]{9}|[0-9]{9}[0-9xX]{1})$"
    RE.Global = True
    
    '指定した文字列に誤りがあった場合は空文字を返す
    If Not RE.Test(isbn9_10) Then
        CalcCheckDigit11_10_2 = ""
        Set RE = Nothing
        Exit Function
    End If
    Set RE = Nothing
    
    '旧規格のISBN(ISBN-10)のチェックディジット計算(Wikipedia参照)
    
    Const MODULUS = 11
    Const WAIT = 10
    
    Dim temp
    Dim sum
    Dim remainder
    Dim ret
    
    Dim index
    
    'チェックディジットを除いた左側の桁から10、9、8…2を掛けてそれらの和を取る。
    sum = 0
    For index = 0 To 8
         temp = (CInt(Mid(isbn9_10, index + 1, 1)) * (WAIT - index))
         sum = sum + temp
    Next
    
    '和を11で割って出た余りを11から引く
    remainder = sum Mod MODULUS
    ret = MODULUS - remainder
    
    'なお、計算結果が10になった場合、10の代わりにX(アルファベットの大文字)を用いる。
    If ret = WAIT Then
        CalcCheckDigit11_10_2 = "X"
        
        'また、11になった場合は、0となる。
    ElseIf ret = MODULUS Then
        CalcCheckDigit11_10_2 = "0"
        
        'それ以外になった場合は、チェックディジットは計算結果の値となる
    Else
        CalcCheckDigit11_10_2 = CStr(ret)
        
    End If
End Function

'ieでAmazonサイトの指定したASIN/ISBN-10商品ページを開き、商品名を取得する
Sub GetItemTitle(code, isIeVisible, isPutResult)
    Dim title
    Dim url
    Dim ie
    Set ie = CreateObject("InternetExplorer.Application")
    ie.Visible = isIeVisible
    
    url = PROTOCOL & "://" & DOMAIN & "/dp/" & code
    ie.Navigate url
    
    On Error Resume Next
    
    WaitIE(ie)
    
    '年齢認証ページかどうか確認。認証ページであれば認証を進める
    AdvancedAgeAuth(ie)
    WaitIE(ie)
    
    title = ie.document.title
    
    'IEを表示しない場合、バックグラウンドで開いているIEを閉じる
    If Not isIeVisible Then
        ie.Quit
    End If
    
    Set ie = Nothing
    
    On Error GoTo 0
    
    If isPutResult Then
        '取得した商品名を出力
        Dim prompt
        prompt = "CODE: " & code & vbCrLf & "URL: " & url & vbCrLf & "TITLE: " & title
        If CheckRunningScript = RUNNING_CSCRIPT Then
            WScript.Echo prompt
        Else
            InputBox prompt, APP_NAME & " " & APP_VERSION, title
        End If
    End If
End Sub

'指定されたIEがECサイトの年齢認証ページであれば認証を進める。
Sub AdvancedAgeAuth(ie)
    Dim domain
    Dim title
    domain = ie.document.domain
    title = ie.document.title
    
    If domain = DOMAIN And _
        InStr(title, TITLE_AGE_AUTH) > 0 Then
        Dim objAnchor
        For Each objAnchor In ie.document.getElementsByTagName("A")
            If InStr(objAnchor.innerText, VERIFY_TOKEN) > 0 Then
                objAnchor.Focus
                objAnchor.click
                Exit For
            End If
        Next
    End If
End Sub

'IEページが表示されるまで待つ
Sub WaitIE(ie)
    Do While ie.Busy = True Or ie.readyState <> 4
    Loop
End Sub

'実行中インタプリタの情報を取得する
'実行中インタプリタ: RUNNING_UNKNOWN=-1, RUNNING_CSCRIPT=0, RUNNING_WSCRIPT=1
Function CheckRunningScript()
    Const WSCRIPT_EXE = "wscript.exe"
    Const CSCRIPT_EXE = "cscript.exe"
    
    If LCase(Right(WScript.FullName, Len(WSCRIPT_EXE))) = WSCRIPT_EXE Then
        CheckRunningScript = RUNNING_WSCRIPT
    ElseIf LCase(Right(WScript.FullName, Len(CSCRIPT_EXE))) = CSCRIPT_EXE Then
        CheckRunningScript = RUNNING_CSCRIPT
    Else
        CheckRunningScript = RUNNING_UNKNOWN
    End If
End Function

'指定した文字列の全角英数を半角に変換して返す
Function StrConvNarrow(strWide)
    Dim length, index, retStr, retChar, tempChar, tempCode
    retStr = ""
    StrConvNarrow = retStr
    
    length = Len(strWide)
    For index = 1 To length
        tempChar = Mid(strWide, index, 1)
        tempCode = Asc(tempChar)
        If (tempCode >= &H824F And tempCode <= &H8258) Or _
            (tempCode >= &H8260 And tempCode <= &H8279) Then
            '文字コードが Shift_JIS 0~9: &H824F~&H8258 
            'または A~Z: &H8260~&H8279 だった場合
            retChar = Chr(tempCode + SHIFT_CODE)
            
        ElseIf tempCode >= &H8281 And tempCode <= &H829A Then
            '文字コードが Shift_JIS a~z: &H8281~&H829A だった場合
            retChar = Chr(tempCode + SHIFT_CODE - 1)
        Else
            '文字コードが変換対象外だった場合
            retChar = tempChar
            
        End If
        retStr = retStr & retChar
    Next
    
    StrConvNarrow = retStr
End Function

英数文字列を半角または全角に変換

VBVBAだとStrConvという便利な関数が使えるのだが、
VBSに該当または同等の関数が無い為作ってみた。

英数のみで言えば文字コードを一定量シフトさせることで
半角または全角変換は難なく実現した。

記号及びカタカナに関してはシフトJISの場合
文字の並びに類似性が無く、
煩雑な実装が必要だったので非対応とした。
(1文字づつ判定して処置してく事になる。)

ASCII文字コード - IT用語辞典

文字コード表 シフトJIS(Shift_JIS)

当初の目的が自作VBSで受け取った
ASIN/ISBNの全角文字列を半角に変換だったから、
これはこれで良しとする。

(余談だが、追加インストールを厭わなければ、
BASP21.DLLを導入することで、
COMコンポーネントからStrConvが使える模様。)

BASP21 DLL


英数全半角変換.vbs

Option Explicit

'ASCII <-> Shift_JIS 文字コード変換補数
Const SHIFT_CODE = &H7DE1

Dim input

'全角英数→半角変換テスト
input = InputBox("全角英数を半角に変換します。", "全角英数を半角に変換")
WScript.Echo "入力: " & input & vbCrLf & _
    "出力: " & StrConvNarrow(input)

'半角英数→全角変換テスト
input = InputBox("半角英数を全角に変換します。", "半角英数を全角に変換")
WScript.Echo "入力: " & input & vbCrLf & _
    "出力: " & StrConvWide(input)


'サブルーチン

'指定した文字列の全角英数を半角に変換して返す
Function StrConvNarrow(strWide)
    Dim length, index, retStr, retChar, tempChar, tempCode
    retStr = ""
    StrConvNarrow = retStr
    
    length = Len(strWide)
    For index = 1 To length
        tempChar = Mid(strWide, index, 1)
        tempCode = Asc(tempChar)
        If (tempCode >= &H824F And tempCode <= &H8258) Or _
            (tempCode >= &H8260 And tempCode <= &H8279) Then
            '文字コードが Shift_JIS 0~9: &H824F~&H8258 
            'または A~Z: &H8260~&H8279 だった場合
            retChar = Chr(tempCode + SHIFT_CODE)
            
        ElseIf tempCode >= &H8281 And tempCode <= &H829A Then
            '文字コードが Shift_JIS a~z: &H8281~&H829A だった場合
            retChar = Chr(tempCode + SHIFT_CODE - 1)
        Else
            '文字コードが変換対象外だった場合
            retChar = tempChar
            
        End If
        retStr = retStr & retChar
    Next
    
    StrConvNarrow = retStr
End Function

'指定した文字列の半角英数を全角に変換して返す
Function StrConvWide(strNarrow)
    Dim length, index, retStr, retChar, tempChar, tempCode
    retStr = ""
    StrConvWide = retStr
    
    length = Len(strNarrow)
    For index = 1 To length
        tempChar = Mid(strNarrow, index, 1)
        tempCode = Asc(tempChar)
        If (tempCode >= &H30 And tempCode <= &H39) Or _
            (tempCode >= &H41 And tempCode <= &H5A) Then
            '文字コードが ASCII 0~9: &H30~&H39 
            'または A~Z: &H41~&H5A だった場合
            retChar = Chr(tempCode - SHIFT_CODE)
            
        ElseIf tempCode >= &H61 And tempCode <= &H7A Then
            '文字コードが ASCII a~z: &H61~&H7A だった場合
            retChar = Chr(tempCode - SHIFT_CODE + 1)
            
        Else
            '文字コードが変換対象外だった場合
            retChar = tempChar
            
        End If
        retStr = retStr & retChar
    Next
    
    StrConvWide = retStr
End Function

旧ISBNコード(ISBN-10)のチェックディジットを計算する

またしても Wikipedia の ISBN ページを参考に実装。

ISBN - Wikipedia

2006年いっぱいで廃止のハズの規格だが、
天下のアマゾンが今だ使い続けるもんだから…
置いといたら少しは需要とか有るかしら?

書く言う自分も少し前、
ちょっとしたアマゾン用ツールを作った際、
必要に迫られて組んだって感じなんで。


ISBN-10チェックディジット計算.vbs

Option Explicit

Dim input

input = InputBox("ISBN9~10桁を入力してください", "ISBN-10チェックディジット計算")
If input = "" Then WScript.Quit
WScript.Echo "ISBN: " & input & vbCrLf & "チェックディジット: " & CalcCheckDigit11_10_2(input)


'指定した数字9桁か10桁、または10桁目が「X」の文字列に対するチェックディジットを返す
'(モジュラス11 ウェイト10-2)。
'指定した文字列に誤りがあった場合は空文字を返す
Function CalcCheckDigit11_10_2(isbn9_10)
    '指定した文字列が数字9桁か10桁、10桁目が「X」の文字列であるか確認
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^([0-9]{9}|[0-9]{9}[0-9xX]{1})$"
    RE.Global = True
    
    '指定した文字列に誤りがあった場合は空文字を返す
    If Not RE.Test(isbn9_10) Then
        CalcCheckDigit11_10_2 = ""
        Set RE = Nothing
        Exit Function
    End If
    Set RE = Nothing
    
    '旧規格のISBN(ISBN-10)のチェックディジット計算(Wikipedia参照)
    
    Const MODULUS = 11
    Const WAIT = 10
    
    Dim temp
    Dim sum
    Dim remainder
    Dim ret
    
    Dim index
    
    'チェックディジットを除いた左側の桁から10、9、8…2を掛けてそれらの和を取る。
    sum = 0
    For index = 0 To 8
         temp = (CInt(Mid(isbn9_10, index + 1, 1)) * (WAIT - index))
         sum = sum + temp
    Next
    
    '和を11で割って出た余りを11から引く
    remainder = sum Mod MODULUS
    ret = MODULUS - remainder
    
    'なお、計算結果が10になった場合、10の代わりにX(アルファベットの大文字)を用いる。
    If ret = WAIT Then
        CalcCheckDigit11_10_2 = "X"
        
        'また、11になった場合は、0となる。
    ElseIf ret = MODULUS Then
        CalcCheckDigit11_10_2 = "0"
        
        'それ以外になった場合は、チェックディジットは計算結果の値となる
    Else
        CalcCheckDigit11_10_2 = CStr(ret)
        
    End If
End Function

ISBNコード(ISBN-13)のチェックディジットを計算する

Wikipedia のチェックディジット解説をまんまベタ実装。

ISBN - Wikipedia

このくらい平坦な方が個人的には分かりやすいかな。

ググれば其処彼処、至る所で様々な言語用のサンプルが
ゴロゴロしているのだが、折角書いたことだし此処で供養しておこう。


ISBN-13チェックディジット計算.vbs

Option Explicit

Dim input

input = InputBox("ISBN12~13桁を入力してください", "ISBN-13チェックディジット計算")
If input = "" Then WScript.Quit
WScript.Echo "ISBN: " & input & vbCrLf & "チェックディジット: " & CalcCheckDigit10_3_1(input)


'指定した数字12桁または13桁の文字列に対するチェックディジットを返す
'(モジュラス10 ウェイト3・1)。
'指定した文字列に誤りがあった場合は空文字を返す
Function CalcCheckDigit10_3_1(isbn12_13)
    '指定した文字列が数字12桁または13桁の文字列であるか確認
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^[0-9]{12,13}$"
    RE.Global = True
    
    '指定した文字列に誤りがあった場合は空文字を返す
    If Not RE.Test(isbn12_13) Then
        CalcCheckDigit10_3_1 = ""
        Set RE = Nothing
        Exit Function
    End If
    Set RE = Nothing
    
    '現行規格のISBN (ISBN-13) のチェックディジット計算(Wikipedia参照)
    
    Const MODULUS = 10
    Const WAIT_ODD = 1
    Const WAIT_EVEN = 3
    
    Dim temp
    Dim sum
    Dim remainder
    Dim ret
    
    Dim index
    For index = 0 To 11
        'チェックディジットを除いた一番左側の桁から順に1、3、1、3…を掛けてそれらの和を取る。
        If ((index + 1) Mod 2) <> 0 Then
            temp = (CInt(Mid(isbn12_13, index + 1, 1)) * WAIT_ODD)
        Else
            temp = (CInt(Mid(isbn12_13, index + 1, 1)) * WAIT_EVEN)
        End If
        sum = sum + temp
    Next
    '和を10で割る
    remainder = sum Mod MODULUS
    
    '和を10で割って出た、余りの下1桁が0の場合はチェック数字を0とする。
    If (remainder Mod 10) = 0 Then
        ret = 0
    Else
        '和を10で割って出た、余りを10から引く。
        ret = MODULUS - remainder
    End If
    
    CalcCheckDigit10_3_1 = CStr(ret)
End Function