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商品コード] [...]]

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

・引数無しの場合(GUI、CUI)

引数無しで実行した場合、
「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コードでの指定が不可なのはその為。

詳細な情報取るならAmazonのAPIで取って来た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 ０～９: &H824F～&H8258 
            'または Ａ～Ｚ: &H8260～&H8279 だった場合
            retChar = Chr(tempCode + SHIFT_CODE)
            
        ElseIf tempCode >= &H8281 And tempCode <= &H829A Then
            '文字コードが Shift_JIS ａ～ｚ: &H8281～&H829A だった場合
            retChar = Chr(tempCode + SHIFT_CODE - 1)
        Else
            '文字コードが変換対象外だった場合
            retChar = tempChar
            
        End If
        retStr = retStr & retChar
    Next
    
    StrConvNarrow = retStr
End Function

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

VB、VBAだと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 ０～９: &H824F～&H8258 
            'または Ａ～Ｚ: &H8260～&H8279 だった場合
            retChar = Chr(tempCode + SHIFT_CODE)
            
        ElseIf tempCode >= &H8281 And tempCode <= &H829A Then
            '文字コードが Shift_JIS ａ～ｚ: &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

JANコードからバーコードフォント用文字列を生成する

同人誌にバーコードを付ける。2の続き。

同人誌にバーコードを付ける。2 - DumBo さんの Homebrew 観察日記

前回から3年ぐらい経ってしまっているが
気にしないで公開。

ソースをVBS対応に修正。
久しぶりに読むチェックディジット算出処理は
正直見辛いと感じたが…手直しするの面倒なんでこのまま。

ExcelVBAなんかの標準モジュールに貼り付ければ
Officeでも使えますよーと。

バーコードフォント(サンプル版)
http://www.vector.co.jp/soft/data/writing/se293727.html
※記載のVBSを活用するのに必要

BarFontVer1.00.vbs

Option Explicit
'
'   BarFont(JAN)補助モジュール
'
'   version 1.00
'   2017/04/12
'
'   by REGEKATSU
'
'   release
'
'   version 1.00
'   同一コードによるVBA/VBScriptでの実行に対応
'
'   version 0.02
'   JANコード標準なら12～13桁、短絡なら7～8桁での入力に対応しています
'   (チェックディジットの計算機能が備わっています。)。
'
'   version 0.01
'   JANコード13桁のみ対応しています。12桁での入力には対応していません
'   (チェックディジットの計算機能はありません。)。
'

'VBAでは下記1行をコメントアウトすること
Call JanCodeToFontChar


'サブルーチン

'入力ボックスに指定されたJANコード標準13桁又は短絡8桁に対するバーコード表示用文字列を、
'同じく入力ボックスに出力します。
'入力無しかキャンセルボタンをクリックすることで、処理が終了します。
Sub JanCodeToFontChar()
    
    Dim RE
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^([0-9]{12,13}|[0-9]{7,8})$"
    
    Const DEFAULT_PROMPT = "JANコード標準13桁又は短絡8桁を入力してください。"
    Dim prompt
    prompt = DEFAULT_PROMPT
    Dim promptNoUseLongBar
    Dim inputNoUseLongBar
    Dim inputCode
    inputCode = ""
    
    Do
        inputCode = InputBox(prompt, "バーコードフォント、表示用変換マクロ", inputCode)
        If RE.Test(inputCode) Then
            prompt = DEFAULT_PROMPT & vbCrLf & vbCrLf & "前回入力JANコード: " & inputCode & vbCrLf
            If MsgBox("バーコードの高さを均一に揃えますか?" & vbCrLf & vbCrLf & _
                "はい(Y): 同サイズ, いいえ(N): ロング", vbYesNo Or vbQuestion, _
                "指定") = vbYes Then
                inputNoUseLongBar = True
                promptNoUseLongBar = "同サイズ"
            Else
                inputNoUseLongBar = False
                promptNoUseLongBar = "ロング"
            End If
            prompt = prompt & "前回バーコードサイズ: " & promptNoUseLongBar & vbCrLf
            inputCode = ConvertFontChar(inputCode, inputNoUseLongBar)
            prompt = prompt & "前回表示用文字列: " & inputCode
            'MsgBox "変換が完了しました。", vbInformation, "完了"
        ElseIf inputCode <> "" Then
            MsgBox "入力に誤りがあります。", vbCritical, "エラー"
        End If
    Loop While inputCode <> ""
    
    Set RE = Nothing
End Sub

'指定したJANコード標準13桁又は短絡8桁に対する、チェックディジットを返します。
'
'パラメータ janCode:        バーコードの文字列。
'                           標準なら12～13桁、短絡なら7～8桁で指定
'戻り値     チェックディジット1桁の文字列。
'           指定に誤りがあれば空白スペースを返す
'
Function CalcCheckDigit(janCode)
    Dim i, j
    Dim checkOdd
    Select Case Len(janCode)
        '短絡8桁の場合。
        Case 7, 8
            For i = 1 To 7
                '奇数桁が何文字目か調べる
                '(チェックデジットを除いた1番右側より奇数桁、右から2番目を偶数桁…と数える。)。
                If i Mod 2 = 1 Then
                    checkOdd = 1
                Else
                    checkOdd = 0
                End If
                '奇数桁の数を3倍に、偶数桁の数を1倍にして全てを合計する。
                j = j + (Asc(Mid(janCode, i, 1)) And &HF) * (1 + 2 * checkOdd)
            Next
            '合計の1の位を10から引いた数がチェックディジットなので、戻り値として返す。
            CalcCheckDigit = Chr(48 + (10 - (j Mod 10)) Mod 10)
        '標準13桁の場合。
        Case 12, 13
            For i = 1 To 12
                '奇数桁が何文字目か調べる
                '(チェックデジットを除いた1番右側より奇数桁、右から2番目を偶数桁…と数える。)。
                If i Mod 2 = 0 Then
                    checkOdd = 1
                Else
                    checkOdd = 0
                End If
                '奇数桁の数を3倍に、偶数桁の数を1倍にして全てを合計する。
                j = j + (Asc(Mid(janCode, i, 1)) And &HF) * (1 + 2 * checkOdd)
            Next
            '合計の1の位を10から引いた数がチェックディジットなので、戻り値として返す。
            CalcCheckDigit = Chr(48 + (10 - (j Mod 10)) Mod 10)
        '標準13桁又は短絡8桁以外の桁数だった場合。
        Case Else
            '指定に誤りがあるので空白スペースを、戻り値として返す。
            CalcCheckDigit = " "
    End Select
End Function

'BarFont(JAN)を利用した、バーコード描画関数です。
'指定したJANコード標準13桁又は短絡8桁、及びロングバーの有無に対する、
'バーコード表示用文字列を返します。
'
'JANコード標準なら12～13桁、短絡なら7～8桁での入力に対応しています
'(チェックディジットの計算機能が備わっています。)。
'
'パラメータ janCode:        バーコードの文字列。
'                           標準なら12～13桁、短絡なら7～8桁で指定
'           noUseLongBar:   ロングバーを使わない場合True
'戻り値     バーコードで表現される文字列
'           指定に誤りがあればNULL文字列を返す
'
Function ConvertFontChar(janCode, noUseLongBar)
    
    '変換文字列用変数。
    Dim janConv
    janConv = ""
    
    'JANコード13桁用、パリティビット算出用テーブル。
    'Dim combiTable(2 To 7)
    Dim combiTable(7)
    combiTable(2) = 32
    combiTable(3) = 16
    combiTable(4) = 8
    combiTable(5) = 4
    combiTable(6) = 2
    combiTable(7) = 1
    Dim prifixTable(9)
    prifixTable(0) = 0  '000000b
    prifixTable(1) = 11 '001011b
    prifixTable(2) = 13 '001101b
    prifixTable(3) = 14 '001110b
    prifixTable(4) = 19 '010011b
    prifixTable(5) = 25 '011001b
    prifixTable(6) = 28 '011100b
    prifixTable(7) = 21 '010101b
    prifixTable(8) = 22 '010110b
    prifixTable(9) = 26 '011010b
    
    '左ガイドバーをセットする。
    janConv = janConv & Chr(&H29 - noUseLongBar - 1)
    Dim i
    Select Case Len(janCode)
    '短絡8桁の場合。
    Case 7, 8
        janCode = Mid(janCode, 1, 7) & CalcCheckDigit(janCode)
        '左側4桁に対する、キャラクタをセットしていく。
        For i = 1 To 4
            janConv = janConv + Chr(Asc(Mid(janCode, i, 1)) + &H20)
        Next
        'センターバーをセットする。
        janConv = janConv & Chr(&H2B - noUseLongBar - 1)
        '右側6桁に対するキャラクタをセットする。
        janConv = janConv & Mid(janCode, 5, 4)
    '標準13桁の場合。
    Case 12, 13
        janCode = Mid(janCode, 1, 12) & CalcCheckDigit(janCode)
        '左側7桁に対する、パリティビットに基づいたキャラクタをセットしていく。
        Dim parityCheck, x
        '左1文字目を取得して、使用するパリティテーブルを決定する。
        x = Asc(Mid(janCode, 1, 1)) And &HF
        '使用するパリティテーブルに基づいて2～7文字目の、奇数または偶数パリティのキャラクタをセットしていく。
        For i = 2 To 7
            parityCheck = 0
            If (combiTable(i) And prifixTable(x)) = 0 Then parityCheck = 1
            janConv = janConv + Chr(Asc(Mid(janCode, i, 1)) + &H10 + (&H10 * parityCheck))
        Next
        'センターバーをセットする。
        janConv = janConv & Chr(&H2B - noUseLongBar - 1)
        '右側6桁に対するキャラクタをセットする。
        janConv = janConv & Mid(janCode, 8, 6)
    '指定に誤りがあった場合。
    Case Else
        janConv = ""
    End Select
    '右ガイドバーをセットする。
    If janConv <> "" Then janConv = janConv & Chr(&H29 - noUseLongBar - 1)
    
    '変換文字列を返す。
    ConvertFontChar = janConv
    
End Function

オレオレ蔵書管理システム(仮)の用件定義

用件定義という名の、ただ要望を羅列しただけのもの。
既に出来ている部分や、まだ未実装の機能だったり、
技術的な検証が済んでいない、希望的観測で綴ったもの等
まちまちっす。

◇◇◇

■機能面

家でも外でも使えるもの。検索、登録、修正、削除、etc…
(家=WindowsPC, 外=スマホ(Android) or タブレット(Kindle)

特に蔵書の検索に効果を発揮するUIであること
(文字列検索は基本として、作家、サークル、カテゴリ、タグは
一覧表示した上で、1アクションで所有作品が絞り込めること)

画像で管理、確認が出来ること
(本の書影、CD、DVDのジャケット等を持ち、
本棚(ブクログ)やスライダー(iTune)のようなGUIを備えていること)

画像無し一覧表示も備えていること
(軽さ、視認性を優先した表形式での表示)

電子書籍、自炊PDF等、手持ちデジタルデータとリンクしている
(家でも外でもデータにアクセスが可能)

登録作業の効率化(自動登録、自動取得)
(API公開されていればそれを使用、無ければスクレイピングで対応。
なお、サムネイル画像の自動保存をも含む)

本以外の物品管理にも対応出来ること
(音楽、ビデオ、アプリ、ハード等)

自動、半自動以外の、登録、修正、削除作業が造作無く行えること

同人作品についても手間なく登録出来ること
(ショップ委託されていればその情報を取得、利用)
・WebAPIを提供している大手ECサイト
Amazon、楽天、Yahoo、DMM、Google Books
・大手同人ショップサイト
とらのあな、メロンブックス、Comic ZIN
・大手同人DL販売サイト
DLsite、メロンブックスDL、DL.Gechu.com
・大手中古ネットショップ
駿河屋、らしんばん、まんだらけ

同人誌即売会で活用出来る仕組みがあること
(サークルチェックリストとの連携、
出展サークルから現在所有の作品を絞り込み
→所有作品を確認して未所有作品を購入する等、
配置マップの動的生成、サークル一覧－配置マップ間の行き来)

■運用面

ストレージ系クラウドサービス活用による、デジタルデータの冗長化
(ローカルで冗長化しつつクラウドでもバックアップを取る)

理想はローカルデータのバックアップを除く部分において、
サーバレス運用出来る仕組みを持たすこと
(サーバ立てる or レンタルサーバ借りる等をしないで済むこと)

運用コストを伴わない構成とすること
(人的労力を極力無くす)

◇◇◇

道半ばにすら及んでいないのはご愛嬌(苦笑)。

オレオレ蔵書管理システム(仮)の現在

書いては捨ててを繰り返しているオレオレ蔵書管理システム(仮)の、
現在までの変遷を残しておきたいと思ったので唐突且つ此処に記載。

◇◇◇

1.Excelワークブックを使った管理
登録とカード目録の作成が不便

dumbo001.hatenablog.com

2.Excelマクロによる管理
外で使えない。
ノートPC運用も試すが、Windowsを外でユルく使うには
難儀なOS(GUI的な意味)だったこと

dumbo001.hatenablog.com
dumbo001.hatenablog.com
dumbo001.hatenablog.com
dumbo001.hatenablog.com
dumbo001.hatenablog.com
dumbo001.hatenablog.com

2.5.自宅サーバ+PHP+MySQLという案
構想だけ。DB設計だけでお腹いっぱいになった

3.Evernote+Googleスプレッドシート+EvcelVBA+C#(登録用)
外で登録出来ない、Windows専用且つExcelが必要、
Amazonスクレイピングの改修が億劫(HTML構造が月1ペース(体感)で変わる)

お手軽な同人誌蔵書管理システムが依然現れないので3度目の挑戦中。自分の技術力じゃクライアントアプリが関の山だった。現在とらのあなとISDNから情報取得してEvernoteとGoogleスプレッドシートに登録するまで実装。先は長い。 pic.twitter.com/QJeIaO2WcG

— DumBo@レゲ活 (@regekatsu) 2016年2月4日

同人誌蔵書管理システム続き。
書誌登録用メニュー画面こさえたり
委託してない本の登録用HTML+JS書いたり
スクレイピングでキンドル本だけは対応してみたり
幾つかのECサイトで年齢認証を突破出来る処理組んだり。
そんな感じ。 pic.twitter.com/dbqAVAxriw

— DumBo@レゲ活 (@regekatsu) 2016年2月28日

3.5.Google Apps Script+同スプレッドシート+同HTMLServive(Webアプリ)
使い辛い、機能が不足している

dumbo001.hatenablog.com
dumbo001.hatenablog.com

4.Google Apps Script+同スプレッドシート+同HTMLServive(Webアプリ+サークルチェック機能)
見た目優先で組んで見たものの、DVDから抜いた
サークルカットをそのまま使うのは著作権的にマズイ気が…

自作のコミケ巡回ツール弄ってたら朝になってしまった…。見えているコントロールの半分が機能未実装っていう #C91 pic.twitter.com/u7lSrVulLn

— DumBo@レゲ活 (@regekatsu) 2016年12月28日

5.Evernote+Google Apps Script+同スプレッドシート+GMail+Amazon API(自動登録)
Kindle本を購入したら自動で登録、
Amazon APIは便利だった(スクレイピング実装の手間と比較した場合)

そもそも…
未登録の蔵書が大量にある
多分5～6000冊持っているであろう(予想)うちの、
1000程度しか済んでない(登録済→キンドル本500冊、同人関連500種)

◇◇◇

納得行くシステムの完成が今も見えていない状態だが
本を買ったり読んだりする事自体は生活の一部だったりするので、
いっそライフラークのようなものだと開き直って向き合ってくのも
一興なのかも知れない。＜戯言

ハドソン ジョイカードとか

昔持っていたんだけど引っ越したとき廃棄したっぽい。
仕方ないのでヤフオクで買い直した。

[FC]ハドソン ジョイカード

ざっと見て回ったが回路図が見当たらないので作成。

[FC]ハドソン ジョイカード 回路図