EXCELのVBAでUTF8のQRコード生成の流用

EXCELのVBAだけでQRコード生成の記事が 便利でした
https://qiita.com/santarou6/items/d623417ea8ba33756108

Bookファイル単体でQRコード(UTF8)を表現できるのが素敵です。

元のシェイプ機能も使ってみたかったのですが、自分の環境ですぐに再現できなかったので
とりあえず画像に保存しようと思いました

# 目次　
（すみません、リンクが機能していません。勉強中です。）
1. [マクロ有効のExcelBookに、QRコード生成のクラスと、ワークシートに貼り付けるクラスを用意します](#1)
    1. [clsQRUTF8](#1-1)
    2. [clsWorkSheetForQR](#1-2)
2. [ボタンクリックなどで、処理を実行する開始用のVBAを作成します](#2)
3. [QRコードにしたい文字列を、QRコードを貼り付けれるExcelのセルの位置に書き込みます](#3)
4. [QRコードを貼り付けれるExcelのセルにコメント（メモ）を追加し、"QRCodeUTF8"を記入します](#4)
5. [(画像生成の処理は、ある程度の時間が必用なため)生成対象のセルを、印刷範囲で限定します](#5)
6. [作成したボタンをクリックなどでVBAを実行します。](#6)
7. [作成されたQRコードを、UTF8のエンコードに対応したソフト（QRコードをデコードし、複数種類ある文字のエンコードを自動判定してくれるような機能があるもの）で読み取って、Excelのセルに書き込んだ値が表示されれば成功です。](#7)
8. [以降は、利用の例です](#8)


使い方
# 1
# マクロ有効のExcelBookに、QRコード生成のクラスと、ワークシートに貼り付けるクラスを用意します

![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3817111/be354c0b-efd6-4aee-b026-c0e6dcd64dc7.png)

## 1-1
## clsQRUTF8
```


'├https://code.google.com/archive/p/barcode-vba-macro-only/downloads
'│QRCode UTF8 Contributions for Excel users
'││
'│├https://github.com/JonasHeidelberg/barcode-vba-macro-only
'││A bug which sometimes caused incorrect output ("stuttering") has been fixed here, but only tested for MSOffice
'││
'│├https://github.com/santarou6/QR_EXCEL/tree/master
'││Japanese (full-width) now works better.
'│││
'││├ThisCode
'│││Paste as PictureShape via a bitmap file

'/------------------------------

Rem  *****  BASIC  *****
Rem This software is distributd under The MIT License (MIT)
Rem Copyright ｩ 2013 Madeta a.s. Jiri Gabriel
Rem Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
Rem The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
Rem THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Rem
Rem 日本語へWebでの翻訳
Rem このソフトウェアはMITライセンスに基づいて配布されており、自由に利用・改変・配布が許可されています。
Rem 著作権表記や免責事項をソフトウェア内に記載することで、利用者が安心して使用できるようにしています。
Rem 具体的には、販売や改変などの行為が可能でありながらも、品質保証は提供しない旨を明記しています。
' ----------------------------------------------------------


Option Explicit


' QRコード128エンコード方式のデータを定義。コードの生成に必要。
Const BCEnc128$ = "1A1B1B1B1A1B1B1B1A0B0B1C0B0C1B0C0B1B0B1B0C0B1C0B0C1B0B1B0B0C1B0C0B1C0B0B0A1B2B0B1A2B0B1B2A0A2B1B0B2A1B0B2B1A1B2B0A1B0A2B1B0B2A1A2B0B1B2A0B2A1A2A2A0B1B2B0A1B2B0B1A2A1B0B2B1A0B2B1B0A1A1A1C1A1C1A1C1A1A0A0C1C0C0A1C0C0C1A0A1C0C0C1A0C0C1C0A1A0C0C1C0A0C1C0C0A0A1A2C0A1C2A0C1A2A0A2A1C0A2C1A0C2A1A2A2A1A1A0C2A1C0A2A1A2A0C1A2C0A1A2A2A2A0A1C2A0C1A2C0A1A2A1A0C2A1C0A2C1A0A2A3A0A1B0D0A3C0A0A0A0B1D0A0D1B0B0A1D0B0D1A0D0A1B0D0B1A0A1B0D0A1D0B0B1A0D0B1D0A0D1A0B0D1B0A1D0B0A1B0A0D3A2A0A1D0A0B0C3A0A0A0B3B0B0A3B0B0B3A0A3B0B0B3A0B0B3B0A3A0B0B3B0A0B3B0B0A1A1A3A1A3A1A3A1A1A0A0A3C0A0C3A0C0A3A0A3A0C0A3C0A3A0A0C3A0C0A0A2A3A0A3A2A2A0A3A3A0A2A1A0D0B1A0B0D1A0B2B1C2A0A1"
' QRコードE13エンコード方式のデータを定義。
Const BCEncE13$ = "C6A5A5B77B5AB6B5A6B66B6AB5B6B6A66A6BA8A5A5D55D5AA5C6B7A55A7BA6C5A7B55B7AA5A8D5A55A5DA7A6B5C55C5BA6A7C5B55B5CC5A6B5A77A5B"
' QRコード39エンコード方式のデータを定義。
Const BCEnc39$ = "0A0C3A3A03A0C0A0A30A3C0A0A33A3C0A0A00A0C3A0A33A0C3A0A00A3C3A0A00A0C0A3A33A0C0A3A00A3C0A3A03A0A0C0A30A3A0C0A33A3A0C0A00A0A3C0A33A0A3C0A00A3A3C0A00A0A0C3A33A0A0C3A00A3A0C3A00A0A3C3A03A0A0A0C30A3A0A0C33A3A0A0C00A0A3A0C33A0A3A0C00A3A3A0C00A0A0A3C33A0A0A3C00A3A0A3C00A0A3A3C03C0A0A0A30C3A0A0A33C3A0A0A00C0A3A0A33C0A3A0A00C3A3A0A00C0A0A3A33C0A0A3A00C3A0A3A00C0C0C0A00C0C0A0C00C0A0C0C00A0C0C0C0"
' QRコード39方式の使用可能な文字セット。
Const BCChs39$ = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. $/+%"
' QRコード39方式の拡張文字セット。
Const BCExt39$ = "%U$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%A%B%C%D%Esp/A/B/C/D/E/F/G/H/I/J/K/L - ./O 0 1 2 3 4 5 6 7 8 9/Z%F%G%H%iJ%V 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%K%L%M%N%O%W+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%P%Q%R%S%T"
' QRコード25エンコード方式のデータを定義。
Const BCEnc25$ = "00110100010100111000001011010001100000111001001010AABBABAAABABAABBBAAAAABABBABAAABBAAAAABBBAABAABABA"
' QRコードで使用可能な文字セット。
Const qralnum$ = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:"

' この変数は使用しているExcelの環境を判別するために使用。
' True: 特定のシステム環境下で動作することを示す。
' False: 通常の環境で動作。
Dim IsMs As Boolean


'------------------------BMP File Begin--------------------------------

'引用元:https://liclog.net/generate-bitmap-vba-image-processing/#google_vignette

'ﾋﾞｯﾄﾏｯﾌﾟﾌｧｲﾙﾍｯﾀﾞ構造体
Private Type BITMAPFILEHEADER
    bfType As String * 2        'ﾌｧｲﾙﾀｲﾌﾟ ("BM")
    bfSize As Long              'ﾌｧｲﾙ全体のｻｲｽﾞ（ﾍｯﾀﾞｰ部ｻｲｽﾞ+ﾃﾞｰﾀ部ｻｲｽﾞ）
    bfReserved1 As Integer      '予約領域（※常に0）
    bfReserved2 As Integer      '予約領域（※常に0）
    bfOffBits As Long           'ﾃﾞｰﾀ部の開始位置（ﾍｯﾀﾞｰ部ｻｲｽﾞ=54）
End Type
 
'ﾋﾞｯﾄﾏｯﾌﾟ情報ﾍｯﾀﾞ構造体
Private Type BITMAPINFOHEADER
    biSize As Long              'この構造体のｻｲｽﾞ
    biWidth As Long             '画像の幅
    biHeight As Long            '画像の高さ
    biPlanes As Integer         '平面数 (※常に1)
    biBitCount As Integer       'ﾋﾟｸｾﾙあたりのﾋﾞｯﾄ数(色深度）)
    biCompression As Long       '圧縮形式
    biSizeImage As Long         '圧縮画像ﾃﾞｰﾀｻｲｽﾞ
    biXPelsPerMeter As Long     '水平方向の解像度
    biYPelsPerMeter As Long     '垂直方向の解像度
    biClrUsed As Long           '使用される色数
    biClrImportant As Long      '重要な色数 (基本は0)
End Type
 
'色情報
Private Type RGBTRIPLE
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
End Type
'------------------------BMP File End --------------------------------
 
 
'-----------------------------------------------------------------------
'-  サンプル処理
'-----------------------------------------------------------------------
Sub sample()
 
    Dim rgbImgData() As RGBTRIPLE
    Dim sPath As String
    
    '出力ﾊﾟｽ定義
    sPath = "C:\Users\...\sample.bmp"
    
    '画像ｻｲｽﾞを定義 (2x2) ※配列は0始まり
    ReDim rgbImgData(1, 1) As RGBTRIPLE
    
    '左上ﾋﾟｸｾﾙ
    With rgbImgData(0, 0)
        .rgbRed = 255
        .rgbGreen = 0
        .rgbBlue = 0
    End With
    
    '右上ﾋﾟｸｾﾙ
    With rgbImgData(0, 1)
        .rgbRed = 0
        .rgbGreen = 255
        .rgbBlue = 0
    End With
    
    '左下ﾋﾟｸｾﾙ
    With rgbImgData(1, 0)
        .rgbRed = 0
        .rgbGreen = 0
        .rgbBlue = 255
    End With
    
    '右下ﾋﾟｸｾﾙ
    With rgbImgData(1, 1)
        .rgbRed = 255
        .rgbGreen = 255
        .rgbBlue = 0
    End With
    
    'ﾋﾞｯﾄﾏｯﾌﾟ出力
    Call subExportBitmap(sPath, rgbImgData)
 
End Sub
 
'-----------------------------------------------------------------------
'-  ﾋﾞｯﾄﾏｯﾌﾟ出力
'-----------------------------------------------------------------------
Private Sub subExportBitmap( _
    sFilePath As String, _
    rgbData() As RGBTRIPLE _
    )
 
    Dim oFSO As Object
    Dim tBFHData As BITMAPFILEHEADER
    Dim tBIHData As BITMAPINFOHEADER
    Dim lWidth As Long
    Dim lHeight As Long
    Dim lFileNumber As Long
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim bTmp As Byte
 
    '既に同名ﾌｧｲﾙが存在していたら削除
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    If oFSO.FileExists(sFilePath) Then
        Call oFSO.DeleteFile(sFilePath)
    End If
    Set oFSO = Nothing
 
    'ﾋﾞｯﾄﾏｯﾌﾟ情報の定義
    lHeight = UBound(rgbData, 1) + 1
    lWidth = UBound(rgbData, 2) + 1
    n = (4 - (lWidth * 3 Mod 4)) Mod 4
 
    'ﾍｯﾀﾞｰ部定義
    With tBFHData
        .bfType = "BM"
        .bfSize = Len(tBFHData) + Len(tBIHData) + 3 * lHeight * lWidth
        .bfOffBits = Len(tBFHData) + Len(tBIHData)
    End With
    With tBIHData
        .biSize = Len(tBIHData)
        .biWidth = lWidth
        .biHeight = lHeight
        .biPlanes = 1
        .biBitCount = 24
        .biCompression = 0
        .biSizeImage = 3 * lHeight * lWidth
        .biXPelsPerMeter = 3780
        .biYPelsPerMeter = 3780
        .biClrUsed = 0
        .biClrImportant = 0
    End With
 
    'ﾋﾞｯﾄﾏｯﾌﾟ出力
    lFileNumber = FreeFile()
    Open sFilePath For Binary As lFileNumber
 
        'ﾍｯﾀﾞｰ部出力
        Put lFileNumber, , tBFHData
        Put lFileNumber, , tBIHData
 
        'ﾃﾞｰﾀ部出力
        For i = lHeight - 1 To 0 Step -1
            For j = 0 To lWidth - 1
                Put lFileNumber, , rgbData(i, j)
            Next
            For j = 1 To n
                Put lFileNumber, , bTmp
            Next
        Next
    Close lFileNumber
 
End Sub

' ----------------------------------------------------------
' Asc関数を使用して、文字コードを取得します。
' 例: "A"の文字コードは65
' VarType関数は値の型を調べます。
' ここではAsc("A")が返す型が「2」であるかどうかを確認しています。
' 型が「2」の場合、IsMs変数をTrueに設定します。それ以外の場合はFalseになります。
'Windows環境かそうでないかの判定っぽい。
' ----------------------------------------------------------
Sub Init()
  If VarType(Asc("A")) = 2 Then
      IsMs = True ' IsMsをTrueに設定 (文字コードが予期する型の場合)
  Else
      IsMs = False ' それ以外の場合、IsMsはFalse
  End If
End Sub

' ----------------------------------------------------------
' EncodeBarcode 関数
' 指定された種類のバーコード（QRコード、Code128など）を生成し、
' グラフィックとしてワークシートに描画するか、またはバーコード文字列を返します。
' ----------------------------------------------------------
Public Function EncodeBarcode( _
    ShIx As Integer, _
    xAddr As String, _
    code As String, _
    pbctype As Integer, _
    Optional pgraficky As Integer, _
    Optional pparams As Integer, _
    Optional pzones As Integer, _
    Optional ByVal intOutputMode As Integer = 2, _
    Optional ByVal strOutputFilePath As String _
    ) As String

    ' 変数の宣言
    '文字列型
    Dim strData As String
  
      '整数型
    Dim bctype%, graficky%, params%, zones%
    'Dim oo As Object
    
    ' 現在の時刻をデバッグウィンドウに表示（ログ用）
    Debug.Print "0100: " & Now
    
    ' 初期化処理を呼び出す（おそらくライブラリや設定の初期化）
    Call Init
    
    ' オプション引数が渡されていなければ、デフォルト値を設定
    If IsMissing(pzones) Then zones = 2 Else zones = pzones   ' 保護ゾーン（バーコードの周囲余白）
    If IsMissing(pparams) Then params = 0 Else params = pparams ' 各バーコード種別に対応したパラメータ
    If IsMissing(pgraficky) Then graficky = 1 Else graficky = pgraficky ' グラフィック描画するか（1）しないか（0）
    If IsMissing(pbctype) Then bctype = 0 Else bctype = pbctype ' バーコードの種類（0=Code128 など）
    
    ' バーコードの種類に応じた処理を行う
    Select Case bctype
        Case 1
            ' EANバーコード（EAN8, EAN13, UPCA, UPCE）
            ' params によって種類やチェックサム有無を設定
            strData = bc_EAN(code, params, zones)
        
        Case 2
            ' Two of Five Interleaved（物流などで使われる）
            strData = bc_25I(code, zones)
        
        Case 3
            ' Code39（英数字用バーコード）
            ' params によって拡張文字セットやチェックサムの有無を制御
            strData = bc_Code39(code, params, zones)
        
        Case 50
            ' DataMatrix（2次元コードの一種）
            ' params = 1 の場合は ASCII エンコードを強制
            strData = dmx_gen(code, IIf(params = 1, "ASCII", ""))
    
        Case 51
            ' QRコード
            ' params によってエラー訂正レベルを設定（0=M, 1=L, 2=Q, 3=H）
            strData = "mode=" & Mid("MLQH", (params Mod 4) + 1, 1)
            Debug.Print "0200: " & Now
            'QRコードを表すASCII文字列を生成する
            strData = fncQR_Gen(code, strData)
            Debug.Print "0300: " & Now
    
      Case Else ' デフォルトは Code128（汎用バーコード）
        ' params によって開始サブセット（A/B/C）を選択
        strData = bc_Code128(code, params, zones)
    End Select
    
    If (False) Then
        Debug.Print ("strData:" & vbCrLf & strData)
    End If
    
    '作業用のRGBTRIPLE
    Dim rgbImgData() As RGBTRIPLE
    
    ' 結果をグラフィックとして描画するかどうか
    If graficky <> 0 Then
        ' 2次元コード（DataMatrixやQR）の場合
        If bctype >= 50 Then
            If IsMs Then
                ' Microsoft用の2D描画
                rgbImgData = bc_2Dms( _
                    strData, _
                    "", _
                    intOutputMode _
                    )
            Else
                ' 通常のExcelシートに2D描画
                Call bc_2D(ShIx, xAddr, strData)
            End If
        Else
            ' 1次元コード（EAN, Code39, Code128など）の場合
            If IsMs Then
              Call bc_1Dms(strData)  ' Microsoft用の1D描画
            Else
              Call bc_1D(ShIx, xAddr, strData)  ' 通常のExcelシートに1D描画
            End If
        End If
        
        Select Case intOutputMode
            Case 2
                'ビットマップファイル出力
                Call subExportBitmap(strOutputFilePath, rgbImgData)
                EncodeBarcode = strOutputFilePath
                
            Case Else
                ' グラフィック描画したので戻り値は空文字列
                EncodeBarcode = ""
        End Select
        
    Else
        ' グラフィックを描画せず、バーコード文字列を返す
        EncodeBarcode = strData
    End If
    
    
    'https://saponote.hatenablog.com/entry/2021/08/23/115000
    
    ' 終了時刻をデバッグ出力
    Debug.Print "0900: " & Now
    
    ' 関数終了
    Exit Function
End Function


Function AscL(s As String) As Long
  If IsMs Then AscL = AscW(s) Else AscL = Asc(s)
End Function

Function bc_25I(chaine$, Optional zones%) As String
  ' start = "0A0A" stop = "1A0"
  Dim i%, j%, k%, l%, s$, q$, zon$
  If IsMissing(zones%) Then
    zon$ = "DD"
  Else
    zon$ = IIf(zones% <= 0, "", Mid$("DDDDDDDDDD", 1, zones%))
  End If
  q = chaine
  s = ""
  For i = 1 To Len(q)
    j = (AscL(Mid(q, i, 1)) Mod 256) - 48
    If (j >= 0 And j <= 9) Then s = s & Chr(48 + j)
  Next
  i = Len(s)
  If i <= 0 Then
    bc_25I = ""
    Exit Function
  End If
  If (i Mod 2) = 1 Then s = "0" & s
  q = zon & "0A0A" ' Start
  For i = 1 To Len(s) Step 2
    j = Val(Mid(s, i, 1)) * 5
    k = 50 + Val(Mid(s, i + 1, 1)) * 5
    For l = 1 To 5
      q = q & Mid(BCEnc25, j + l, 1) & Mid(BCEnc25, k + l, 1)
    Next
  Next
  bc_25I = q & "01A0" & zon
End Function

Function bc_Code39(chaine$, Optional params%, Optional zones%) As String
  ' params extended charset 2 = disabled, 1 = always, 0 = automaticaly
  '         4 = add checksum
  '[bWbwBwBwb]w[BwbwbWbwB]w[bWbwBwBwb] start = 0C0A2A2A0A  stop = A0C0A2A2A0
  Dim i, j%, s$, p$, q$, zon$, ext%, ch%, check%
  If IsMissing(zones) Then
    zon$ = "DD"
  Else
    zon$ = IIf(zones <= 0, "", Mid("DDDDDDDDDD", 1, zones))
  End If
  If IsMissing(params) Then
    check = 0
    ext = 0
  Else
    check = Int(params / 4) Mod 2
    ext = (params Mod 4) - 1
  End If
  s = chaine
  If Len(s) <= 0 Then
    bc_Code39 = ""
    Exit Function
  End If
  If ext = -1 Then
    ' Need extend ?
    For i = 1 To Len(s)
      p = Mid(s, i, 1)
      j = InStr(BCChs39, p)
      If j <= 0 Or AscL(p) > 90 Then
        ext = 1
        Exit For
      End If
    Next
  End If
  If ext = 1 Then
    p = s
    s = ""
    For i = 1 To Len(p)
      j = AscL(Mid(p, i, 1)) Mod 256
      If j = 32 Then
        s = s & " "
      ElseIf (j <= 127) Then
        s = s & Trim(Mid(BCExt39, 1 + j * 2, 2))
      End If
    Next
  End If
  q = zon & "0C0A2A2A0A" ' Start *
  ch = 0
  For i = 1 To Len(s)
    p = Mid(s, i, 1)
    j = InStr(BCChs39, p) - 1
    If j >= 0 And j < 43 Then
      ch = (ch + j) Mod 43
      q = q & Mid(BCEnc39, j * 9 + 1, 9) & "A"
    End If
  Next
  If check = 1 Then q = q & Mid(BCEnc39, ch * 9 + 1, 9) & "A"
  bc_Code39 = q & "0C0A2A2A0" & zon
End Function

Function bc_EAN(chaine$, Optional params%, Optional zones%) As String
  'Parameters : String up to 13 chars wide,
  ' params 1,2,3,4 = EAN13,EAN8,UPCA,UPCE - type
  '        + 8 add checksum
  Dim i%, j%, checksum%, first%, CodeBarre$, s$, p$, q$, zon$, subtyp%, check%
  Dim tableA As Boolean
  If IsMissing(zones) Then
    zon$ = "DD"
  Else
    zon$ = IIf(zones <= 0, "", Mid("DDDDDDDDDD", 1, zones))
  End If
  If IsMissing(params) Then
    check = 0
    subtyp = 0
  Else
    check = Int(params / 8) Mod 2
    subtyp = params Mod 8
  End If
  s = chaine
  p = ""
  CodeBarre = zon
  For i = 1 To Len(s)
    j = AscL(Mid(s, i, 1)) Mod 256
    If j >= 48 Or j <= 57 Then p = p & Chr(j)
  Next i
  s = p
  If subtyp = 4 Then
    While Len(s) < 6
      s = "0" & s
    Wend
    If Len(s) > 6 Then s = Left(s, 6)
    p = s
    first = Val(Right(p, 1))
    If first >= 5 Then
      s = "00" & Left(p, 5) & "0000" & Right(p, 1)
    ElseIf first = 4 Then
      s = "00" & Left(p, 4) & "00000" & Mid(p, 5, 1)
    ElseIf first = 3 Then
      s = "00" & Left(p, 3) & "00000" & Mid(p, 4, 2)
    Else
      s = "00" & Left(p, 2) & Right(p, 1) & "0000" & Mid(p, 3, 3)
    End If
  End If
  If check = 1 Or subtyp = 4 Then s = s & "0"
  While Len(s) < 13
    s = "0" & s
  Wend
  checksum = 0
  first = 1
  For i = 1 To 12
    j = AscL(Mid(s, i, 1)) Mod 256
    checksum = (checksum + first * (j - 48)) Mod 10
    first = (first + 2) Mod 4
  Next
  'Kontrolni soucet
  s = Left(s, 12) & Chr(48 + (10 - checksum Mod 10) Mod 10)
  If subtyp = 4 Then
    s = "000000" & Right(s, 1) & p
  End If
  If Left(s, 12) <> "000000000000" Then
    CodeBarre = CodeBarre & "0A0"
    If subtyp = 0 And Left(s, 5) = "00000" Then subtyp = 2 ' EAN8
    If subtyp = 0 And Left(s, 1) = "0" Then subtyp = 3 ' UPC-A
    ' Jinak EAN13
    If subtyp = 0 Then subtyp = 1
    If subtyp = 2 Then ' EAN8
      j = 5
      p = "0000LLLLRRRR"
    ElseIf subtyp = 3 Then ' UPC-A
      j = 1
      p = "LLLLLLRRRRRR"
    ElseIf subtyp = 4 Then ' UPC-E
      first = Val(Mid(s, 7, 1)) ' check
      j = 7
      p = "000000" & Mid("GGGLLLGGLGLLGGLLGLGGLLLGGLGGLLGLLGGLGLLLGGGLGLGLGLGLLGGLLGLG", 1 + first * 6, 6)
    Else ' EAN13
      j = 1
      first = Val(Left(s, 1))
      p = Mid("LLLLLLLLGLGGLLGGLGLLGGGLLGLLGGLGGLLGLGGGLLLGLGLGLGLGGLLGGLGL", 1 + first * 6, 6) + "RRRRRR"
    End If
    For i = j To 12
      first = Val(Mid(s, i + 1, 1))
'      L       G       R     BarsAndSpaces                          G=rev(R)=rev(inv(L)) R=Inv(L)
'0      0001101 0100111 1110010 C1A0 A0B2 2B0A
'1      0011001 0110011 1100110 B1B0 A1B1 1B1A
'2      0010011 0011011 1101100 B0B1 B1A1 1A1B
'3      0111101 0100001 1000010 A3A0 A0D0 0D0A
'4      0100011 0011101 1011100 A0C1 B2A0 0A2B
'5      0110001 0111001 1001110 A1C0 A2B0 0B2A
'6      0101111 0000101 1010000 A0A3 D0A0 0A0D
'7      0111011 0010001 1000100 A2A1 B0C0 0C0B
'8      0110111 0001001 1001000 A1A2 C0B0 0B0C
'9      0001011 0010111 1110100 C0A1 B0A2 2A0B
      q = Mid(BCEncE13, 1 + first * 12, 12)
      Select Case Mid(p, i, 1)
        Case "L"
          CodeBarre = CodeBarre & Mid(q, 1, 4)
        Case "G"
          CodeBarre = CodeBarre & Mid(q, 5, 4)
        Case "R"
          CodeBarre = CodeBarre & Mid(q, 9, 4)
      End Select
      Select Case subtyp
        Case 1: If i = 6 Then CodeBarre = CodeBarre & "A0A0A"
        Case 3: If i = 6 Then CodeBarre = CodeBarre & "A0A0A"
        Case 2: If i = 8 Then CodeBarre = CodeBarre & "A0A0A"
      End Select
    Next
    If subtyp = 4 Then CodeBarre = CodeBarre & "A0A"
    CodeBarre = CodeBarre & "0A0"
  End If
  bc_EAN = CodeBarre & zon
End Function

Function bc_Code128(chaine$, Optional params%, Optional zones%) As String
  'Parameters : a string
  'Return : * a string which give the bar code when it is dispayed with BarsAndSpaces.TTF font
  '         * an empty string if the supplied parameter is no good
  Dim i%, checksum&, checkw&, min$, n%, zon$, s$, c128$, tbl$, q$, j%
  If IsMissing(zones) Then
    zon$ = "DD"
  Else
    zon$ = IIf(zones <= 0, "", Mid("DDDDDDDDDD", 1, zones))
  End If
'  If IsMissing(params) Then
'  Else
  c128 = ""
  s = chaine
  If Len(s) <= 0 Then
    bc_Code128 = ""
    Exit Function
  End If
  'Calculation of the code string with optimized use of tables A,B and C
  min = ""
  If (params Mod 4) >= 1 And (params Mod 4) <= 3 Then
    tbl = Mid("ABC", params Mod 4, 1)
  Else
    tbl = ""
  End If
  i = 1 'i become the string index
  Do While i <= Len(s)
    n = AscL(Mid(s, i, 1)) Mod 256
    If n = 95 Then ' _ escape _1 FNC1 .. _4 FNC4 __ = podtrzitko
      i = i + 1
      If i > Len(s) Then n = 0 Else n = AscL(Mid(s, i, 1)) Mod 256
      If (n >= 49 And n <= 52) Then
        n = 48 - n
      ElseIf n >= 64 And n <= 94 Then
        n = n - 64
        ' _@,_A .. _^ = 0x00..0x1E
      ElseIf n = 48 Then
        ' _0 = 0x1F
        n = 31
      Else
        n = 95
      End If
    End If
    If n >= 128 Then
      n = n Mod 128
      min = min & "z"
      c128 = c128 & "-05" ' shift
    End If
    Select Case n
      Case 48 To 57, -1
        min = min & "C"
      Case -4 To -2
        min = min & "z"
      Case 0 To 31
        min = min & "A"
      Case 32 To 63
        min = min & "z"
      Case Else ' 64 to 127
        min = min & "B"
    End Select
    q = "000" & Trim(CStr(Abs(n)))
    If n < 0 Then q = "-" & Right(q, 2) Else q = Right(q, 3)
    c128 = c128 & q
    i = i + 1
  Loop
  s = zon
  If tbl = "" Then
    If Left(min, 4) = "CCCC" Then
      tbl = "C"
    ElseIf InStr(min, "A") <= 0 Or Left(min, 1) = "B" Then
      tbl = "B"
    Else
      tbl = "A"
    End If
  End If
  n = 103 + AscL(tbl) - 65 ' 103,104,105 = Start A,B,C
  s = s & Mid(BCEnc128, 6 * n + 1, 6)
  checksum = n
  checkw = 1
  i = 1
  Do While i <= Len(min)
    n = Val(Mid(c128, -2 + (i * 3), 3))
    q = Mid(min, i, 1)
    Select Case tbl
      Case "C"
        If q <> "C" Then
          If q = "A" Or (q = "z" And InStr(Mid(min, i), "B") < 0) Then
            tbl = "A"
            n = 101
          Else
            tbl = "B"
            n = 100
          End If
          i = i - 1
        Else
          If (n = -1) Then
            n = 102 ' Fnc 1
          Else
            ' Dvojcislo
            j = (n - 48) * 10
            If (i >= Len(min) Or Mid(min, i + 1, 1) <> "C") Then
              tbl = "B"
              n = 100
              i = i - 1
            Else
              i = i + 1
              n = Val(Mid(c128, -2 + (i * 3), 3))
              If n < 0 Then
                tbl = "B"
                n = 100
                i = i - 2
              Else
                n = j + (n - 48)
              End If
            End If
          End If
        End If
      Case "A"
        If q = "B" Then
          n = 100 ' Switch to B
          i = i - 1
          tbl = "B"
        ElseIf Mid(min, i, 4) = "CCCC" Then
          n = 99 ' Start C
          i = i - 1
          tbl = "C"
        Else
          Select Case n
          Case -5: n = 98
          Case -4: n = 101
          Case -3: n = 96
          Case -2: n = 97
          Case -1: n = 102
          Case 0 To 31
            n = n + 64
          Case Else
            n = n - 32
          End Select
        End If
      Case "B"
        If q = "A" Then
          n = 101 ' Switch to B
          i = i - 1
          tbl = "A"
        ElseIf Mid(min, i, 4) = "CCCC" Then
          n = 99 ' Start C
          i = i - 1
          tbl = "C"
        Else
          Select Case n
          Case -5: n = 98
          Case -4: n = 100
          Case -3: n = 96
          Case -2: n = 97
          Case -1: n = 102
          Case Else
            n = n - 32
          End Select
        End If
    End Select
    If n >= 0 And n <= 102 Then
      s = s & Mid(BCEnc128, 6 * n + 1, 6)
      checksum = (checksum + checkw * n) Mod 103
      checkw = checkw + 1
    End If
    i = i + 1
  Loop
  n = checksum Mod 103
  s = s & Mid(BCEnc128, 6 * n + 1, 6)
  s = s + "1C2A0A1"
  bc_Code128 = s & zon
End Function

Function dmx_place(parr As Variant, psiz As Integer, _
                   pbl As Integer, prow As Integer, pcol As Integer, _
                   pbit As Integer) As Boolean
  Dim ix%, va%, r%, c%, s%
  r = prow
  c = pcol
  If psiz > 0 Then
    s = psiz / pbl
    If r < 0 Then
      r = r + psiz
      c = c + 4 - ((psiz + 4) Mod 8)
    End If
    If c < 0 Then
      c = c + psiz
      r = r + 4 - ((psiz + 4) Mod 8)
    End If
    If c >= psiz Then
      c = c - psiz
      r = r + 1
    End If
    r = r + (Int(r / s) * 2)
    c = c + (Int(c / s) * 2)
  End If
  dmx_place = False
  r = r + 2
  c = c + 2
  ix = r * 20 + Int(c / 8) ' 20 bytes per row
  If ix > (UBound(parr, 2)) Or ix < 0 Then Exit Function
'  c = 2^(7 - (c MOD 8))
  c = 2 ^ (c Mod 8)
  va = parr(0, ix)
  If psiz > 0 Then
    If (Int(va / c) Mod 2) = 0 Then
      If pbit < 0 Then
        dmx_place = True
        Exit Function
      End If
      parr(0, ix) = va + c
    Else
      Exit Function
    End If
  End If
  If pbit > 0 Then
    va = parr(1, ix)
    If (Int(va / c) Mod 2) = 0 Then va = va + c ' else va = va - c
    parr(1, ix) = va
  End If
  dmx_place = True
End Function

Function dmx_placebyte(parr As Variant, psiz As Integer, pbl As Integer, _
                       ByRef prow As Variant, ByRef pcol As Variant, pbyte As Integer) As Boolean
  Dim bity(7) As Integer
  Dim xv As Boolean
  Dim i, x%
  x = pbyte
  For i = 7 To 0 Step -1
    bity(i) = x Mod 2
    x = Int(x / 2)
    If Not (dmx_place(parr, psiz, pbl, (prow(i)), (pcol(i)), -1)) Then
      dmx_placebyte = False
      Exit Function
    End If
  Next
  For i = 0 To 7
    xv = dmx_place(parr, psiz, pbl, (prow(i)), (pcol(i)), bity(i))
  Next
  dmx_placebyte = True
End Function

Function dmx_can_put(parr As Variant, psiz As Integer, pbl As Integer, _
                     prow As Integer, pcol As Integer, pbyte As Integer, _
                     pcorner As Boolean) As Boolean
  Dim dmxtype As Integer
  Dim wr As Variant
  Dim wc As Variant
  dmxtype = 0
  dmx_can_put = False
  If pcorner Then
    If prow = psiz And pcol = 0 Then
      dmxtype = 1   ' LowerLeft
    ElseIf prow = (psiz - 2) And pcol = 0 And (psiz Mod 4) <> 0 Then
      dmxtype = 2   ' lower left 2
    ElseIf prow = (psiz - 2) And pcol = 0 And (psiz Mod 8) = 4 Then
      dmxtype = 3   ' lower left 3
    ElseIf prow = (psiz + 4) And pcol = 2 And (psiz Mod 8) = 0 Then
      dmxtype = 4   ' lower right
    End If
    If dmxtype = 0 Then Exit Function
  End If
  Select Case dmxtype
    Case 1
      wr = Array(psiz - 1, psiz - 1, psiz - 1, 0, 0, 1, 2, 3)
      wc = Array(0, 1, 2, psiz - 2, psiz - 1, psiz - 1, psiz - 1, psiz - 1)
    Case 2
      wr = Array(psiz - 3, psiz - 2, psiz - 1, 0, 0, 0, 0, 1)
      wc = Array(0, 0, 0, psiz - 4, psiz - 3, psiz - 2, psiz - 1, psiz - 1)
     Case 3
      wr = Array(psiz - 3, psiz - 2, psiz - 1, 0, 0, 1, 2, 3)
      wc = Array(0, 0, 0, psiz - 2, psiz - 1, psiz - 1, psiz - 1, psiz - 1)
    Case 4
      wr = Array(psiz - 1, psiz - 1, 0, 0, 0, 1, 1, 1)
      wc = Array(0, psiz - 1, psiz - 3, psiz - 2, psiz - 1, psiz - 3, psiz - 2, psiz - 1)
    Case Else
      wr = Array(prow - 2, prow - 2, prow - 1, prow - 1, prow - 1, prow, prow, prow)
      wc = Array(pcol - 2, pcol - 1, pcol - 2, pcol - 1, pcol, pcol - 2, pcol - 1, pcol)
  End Select
  dmx_can_put = dmx_placebyte(parr, psiz, pbl, wr, wc, pbyte)
End Function ' dmx_can_put

'  Function exor(pa as integer, pb as integer) as INTEGER
'    Dim exorr as integer
'    Dim exorb as integer
'    exorr = 0 : exorb = 1
'    do while exorb <= pa or exorb <= pb
'      IF (int(pa / exorb) MOD 2) <> (int(pb / exorb) MOD 2) THEN exorr = exorr + exorb
'      exorb = exorb + exorb
'    loop
'    exor = exorr
'    exor = pa XOR pb
'  END Function ' exor

Sub dmx_rs(ppoly As Integer, pmemptr As Variant, ByVal psize As Integer, ByVal plen As Integer, ByVal pblocks As Integer)
    Dim v_x%, v_y%, v_z%, v_a%, v_b%, pa%, pb%, rp%
    Dim poly(512) As Integer
    Dim v_ply() As Integer
    
    ' generate reed solomon expTable and logTable
    '   for datamatrix GF256(0x012D) // 0x12d=301 => x^8 + x^5 + x^3 + x^2 + 1
    '   QR uses GF256(0x11d) // 0x11d=285 => x^8 + x^4 + x^3 + x^2 + 1
    v_x = 1: v_y = 0
    Do
      poly(v_x) = v_y   ' expTable
      poly(v_y + 256) = v_x ' logTable
      If v_x = 0 Then Exit Do
      v_x = v_x * 2
      v_y = v_y + 1
      If v_x > 255 Then v_x = v_x Xor ppoly
      If v_x = 1 Then v_x = 0
    Loop
' for 301 check:
' 255,0,1,240,2,225,241,53,3,38,226,133,242,43,54,210,4,195,39,114,227,106,134,28,243,140,44,23,55,118,211,234,5,219,196,96,40,222,115,103,228,78,107,125,135,8,29,162,244,186,141,180,45,99,24,49,56,13,119,153,212,199,235,91,6,76,220,217,197,11,97,184,41,36,223,253,116,138,104,193,229,86,79,171,108,165,126,145,136,34,9,74,30,32,163,84,245,173,187,204,142,81,181,190,46,88,100,159,25,231,50,207,57,147,14,67,120,128,154,248,213,167,200,63,236,110,92,176,7,161,77,124,221,102,218,95,198,90,12,152,98,48,185,179,42,209,37,132,224,52,254,239,117,233,139,22,105,27,194,113,230,206,87,158,80,189,172,203,109,175,166,62,127,247,146,66,137,192,35,252,10,183,75,216,31,83,33,73,164,144,85,170,246,65,174,61,188,202,205,157,143,169,82,72,182,215,191,251,47,178,89,151,101,94,160,123,26,112,232,21,51,238,208,131,58,69,148,18,15,16,68,17,121,149,129,19,155,59,249,70,214,250,168,71,201,156,64,60,237,130,111,20,93,122,177,150
' 1,2,4,8,16,32,64,128,45,90,180,69,138,57,114,228,229,231,227,235,251,219,155,27,54,108,216,157,23,46,92,184,93,186,89,178,73,146,9,18,36,72,144,13,26,52,104,208,141,55,110,220,149,7,14,28,56,112,224,237,247,195,171,123,246,193,175,115,230,225,239,243,203,187,91,182,65,130,41,82,164,101,202,185,95,190,81,162,105,210,137,63,126,252,213,135,35,70,140,53,106,212,133,39,78,156,21,42,84,168,125,250,217,159,19,38,76,152,29,58,116,232,253,215,131,43,86,172,117,234,249,223,147,11,22,44,88,176,77,154,25,50,100,200,189,87,174,113,226,233,255,211,139,59,118,236,245,199,163,107,214,129,47,94,188,85,170,121,242,201,191,83,166,97,194,169,127,254,209,143,51,102,204,181,71,142,49,98,196,165,103,206,177,79,158,17,34,68,136,61,122,244,197,167,99,198,161,111,222,145,15,30,60,120,240,205,183,67,134,33,66,132,37,74,148,5,10,20,40,80,160,109,218,153,31,62,124,248,221,151,3,6,12,24,48,96,192,173,119,238,241,207,179,75,150,0
    ReDim v_ply(plen + pblocks)
    For v_x = 1 To plen + 1
      pmemptr(v_x + psize) = 0
    Next
    For v_b = 0 To (pblocks - 1)
      v_ply(v_b + 1) = 1
      v_z = 1
      v_x = v_b + 1 + pblocks
      Do While v_x <= plen + pblocks
        v_ply(v_x) = v_ply(v_x - pblocks)
        v_y = v_x - pblocks
        Do While v_y >= v_b + 1 + pblocks
          pa = v_ply(v_y): pb = poly(256 + v_z): GoSub rsprod
          v_ply(v_y) = v_ply(v_y - pblocks) Xor rp
          v_y = v_y - pblocks
        Loop
        pa = v_ply(v_b + 1): pb = poly(256 + v_z): GoSub rsprod
        v_ply(v_b + 1) = rp
        v_z = v_z + 1
        v_x = v_x + pblocks
      Loop
      ' generate "nc" checkwords in the array
      v_x = v_b + 1
      Do While v_x <= psize
        v_y = v_b + 1
        v_z = pmemptr(v_y + psize) Xor pmemptr(v_x)
        v_a = plen - pblocks + 1 + v_b ' pro pblocks = 1 je to plen ; pro blocks = 2 to musiﾂｭbyt plen - pblocks + p_b + 1
        Do While v_y <= plen
          pa = v_z: pb = v_ply(v_a): GoSub rsprod
          pmemptr(v_y + psize) = pmemptr(v_y + psize + pblocks) Xor rp
          v_y = v_y + pblocks
          v_a = v_a - pblocks
        Loop
        v_x = v_x + pblocks
      Loop
    Next
    Exit Sub
rsprod:
    rp = 0
    If pa > 0 And pb > 0 Then rp = poly(256 + (poly(pa) + poly(pb)) Mod 255)
    Return
End Sub ' reed solomon dmx_rs

'  Sub setMousePointer(oWin, bEnable As Boolean)
'    Dim oPointer, iPoint%
'    If bEnable Then
'      iPoint = com.sun.star.awt.SystemPointer.ARROW
'    Else
'      iPoint = com.sun.star.awt.SystemPointer.Wait
'    End If
'    oPointer = createUnoService("com.sun.star.awt.Pointer")
'    oPointer.setType (iPoint)
'    oWin.setPointer (oPointer)
'  End Sub

Function dmx_gen(ptext As String, poptions As String) As String
    Dim encoded1(2200) As Integer
    Dim encoded2(3300) As Integer
    Dim encoded3(3300) As Integer
    Dim encix(3) As Integer
    Dim SavedPointer As Variant
    Dim enctype%, dmx_row%, dmx_col%
    Dim i&, j&, k&
    Dim ch%, bl%, s%, siz%
    Dim ascimatrix As String
    Dim err As String
    Dim arr() As Integer
    Dim x As Boolean
    dmx_row = 0
    ascimatrix = ""
    err = ""
    dmx_gen = ""
'    setMousePointer(wnd,False)
    If ptext = "" Then
      err = "Not data"
      Exit Function
    End If
    encix(1) = 0
    If (InStr(poptions, "ASCII") > 0) Then
      enctype = 1
      encix(2) = -1
      encix(3) = -1
    Else
      enctype = 0
      encix(2) = 0
      encix(3) = 0
    End If
    For i = 1 To Len(ptext)
      ch = AscL(Mid(ptext, i, 1)) Mod 256
      j = -5
      ' F1=_1 _=__ : ASCII=chr(232) C40&Text=chr(1) + chr(27)
      If i < Len(ptext) Then
        k = AscL(Mid(ptext, i + 1, 1)) Mod 256
        If Mid(ptext, i, 2) = "_1" Then
          j = -1
          i = i + 1
        ElseIf ch >= 48 And ch <= 57 And k >= 48 And k <= 57 Then
          j = Val(Mid(ptext, i, 2))
        ElseIf Mid(ptext, i, 2) = "__" Then ' podtrzitko
          i = i + 1
          j = -5
        End If
      End If
      ' ascii encoding
      If encix(1) >= 0 And dmx_row = 0 Then
        If j = -1 Then
          encix(1) = encix(1) + 1
          encoded1(encix(1)) = 232
        Else
          If (ch >= 128) Then
            encix(1) = encix(1) + 1
            encoded1(encix(1)) = 235 ' hi bit
            ch = ch - 128
          End If
          If j >= 0 Then
            encix(1) = encix(1) + 1
            encoded1(encix(1)) = j + 130
            dmx_row = 1 ' SKIP NEXT ASCII
          Else
            encix(1) = encix(1) + 1
            encoded1(encix(1)) = ch + 1
          End If
        End If
      Else
        dmx_row = 0 ' no skip next ASCII
      End If
      ' C40 encoding
      If encix(2) >= 0 Then
        ' chr(230) Start C40
        If j = -1 Then ' FNC 1
          encix(2) = encix(2) + 2
          encoded2(encix(2) - 1) = 1  ' set 2
          encoded2(encix(2)) = 27 ' set2 FNC1
        Else
          If ch > 128 Then
            encix(2) = encix(2) + 2
            encoded2(encix(2) - 1) = 1
            encoded2(encix(2)) = 30  ' set2 hi-bit
            ch = ch - 128
          End If
          If ch < 32 Then
            encix(2) = encix(2) + 2
            encoded2(encix(2) - 1) = 0
            encoded2(encix(2)) = ch ' set1 control
          Else
            k = InStr(" 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", Chr(ch))
            If ch <= 90 And k > 0 Then
              encix(2) = encix(2) + 1
              encoded2(encix(2)) = k + 2 ' set0 default
            Else
              k = InStr("!""#$%&'()*+,-./:;<=>?@(\)^_", Chr(ch))
              If (k > 0) Then
                encix(2) = encix(2) + 2
                encoded2(encix(2) - 1) = 1
                encoded2(encix(2)) = k - 1 ' set 2
              Else
                k = InStr("`abcdefghijklmnopqrstuvwxyz{|}~", Chr(ch))
                If (k > 0) Then
                  encix(2) = encix(2) + 2
                  encoded2(encix(2) - 1) = 2 ' set 3
                  encoded2(encix(2)) = k - 1
                Else
                  encix(2) = -1
                End If
              End If
            End If
          End If
        End If
        If encix(2) > UBound(encoded2) - 10 Then encix(2) = -1
      End If
      ' Text encoding
      If encix(3) >= 0 Then
        ' chr(239) start Text
        If j = -1 Then ' FNC 1
          encix(3) = encix(3) + 2
          encoded3(encix(3) - 1) = 1
          encoded3(encix(3)) = 27
        Else
          If ch > 128 Then
            encix(3) = encix(3) + 2
            encoded3(encix(3) - 1) = 1
            encoded3(encix(3)) = 30  ' set2 hi-bit
            ch = ch - 128
          End If
          If (ch < 32) Then
            encix(3) = encix(3) + 2
            encoded3(encix(3) - 1) = 0
            encoded3(encix(3)) = ch ' set1 control
          Else
            k = InStr(" 0123456789abcdefghijklmnopqrstuvwxyz", Chr(ch))
            If (ch < 65 Or ch >= 97) And k > 0 Then
              encix(3) = encix(3) + 1
              encoded3(encix(3)) = k + 2 ' set0
            Else
              k = InStr("!""#$%&'()*+,-./:;<=>?@(\)^_", Chr(ch))
              If (k > 0) Then
                encix(3) = encix(3) + 2
                encoded3(encix(3) - 1) = 1
                encoded3(encix(3)) = k - 1 ' set2
              Else
                k = InStr("`ABCDEFGHIJKLMNOPQRSTUVWXYZ{|}~", ch)
                If (k > 0) Then
                  encix(3) = encix(3) + 2
                  encoded3(encix(3) - 1) = 2
                  encoded3(encix(3)) = k - 1 ' set3
                Else
                  encix(3) = -1
                End If
              End If
            End If
          End If
        End If
        If encix(3) > UBound(encoded3) - 10 Then encix(3) = -1
      End If
      If encix(1) > UBound(encoded1) - 20 Then
         err = "Too long text"
'         setMousePointer(wnd,True)
         Exit Function
      End If
    Next i
    i = encix(1): j = 10000: k = 10000
    If enctype = 0 Then
      If encix(1) <= 0 Then i = 10000
      If encix(2) > 0 Then j = 2 + Int((encix(2) * 2) / 3)
      If encix(3) > 0 Then k = 2 + Int((encix(3) * 2) / 3)
      If i < j And i < k Then
        enctype = 1
      ElseIf j < i And j < k Then
        enctype = 2
      ElseIf k < i And k < j Then
        enctype = 3
      End If
    End If
    ' string not convertible
    If encix(enctype) <= 0 Then
      err = "Bad chars"
'      setMousePointer(wnd,True)
      Exit Function
    End If
    If enctype > 1 Then
      i = 1
      k = 1
      dmx_row = encix(enctype) + 1
      If enctype = 2 Then
        encoded1(1) = 230 ' start enc
        encoded2(dmx_row) = 0 ' padding
        encoded2(dmx_row + 1) = 0 ' padding
      Else
        encoded1(1) = 239 ' start enc
        encoded3(dmx_row) = 0 ' padding
        encoded3(dmx_row + 1) = 0 ' padding
      End If
      Do While i <= dmx_row:
        If enctype = 2 Then
          j = 1600& * encoded2(i) + 40& * encoded2(i + 1) + 1& + encoded2(i + 2)
        Else
          j = 1600& * encoded3(i) + 40& * encoded3(i + 1) + 1& + encoded3(i + 2)
        End If
        i = i + 3
        k = k + 2
        encoded1(k - 1) = Int(j / 256)
        encoded1(k) = j Mod 256
      Loop
      j = 254& + (129& * 256&) ' padding 254,129 = switch to text, end of message
      encix(1) = k
    Else
      j = 129 ' END = 129
'      j = 129& + (251& * 256&) + (147& * 65536)  ' END = 129 + padding 251,147 - test Wikipedia
    End If
    i = encix(1)
    k = 0: ch = 1
    ' only sqare types implemented
    Do
      Select Case i
        Case 3: siz = 8: k = 5
        Case 5: siz = 10: k = 7
        Case 8: siz = 12: k = 10
        Case 12: siz = 14: k = 12
        Case 18: siz = 16: k = 14
        Case 22: siz = 18: k = 18
        Case 30: siz = 20: k = 20
        Case 36: siz = 22: k = 24
        Case 44: siz = 24: k = 28
        Case 62: siz = 28: k = 36
        Case 86: siz = 32: k = 42
        Case 114: siz = 36: k = 48
        Case 144: siz = 40: k = 56
        Case 174: siz = 44: k = 68
        Case 204: siz = 48: k = 84: ch = 2
        Case 280: siz = 56: k = 112: ch = 2
        Case 368: siz = 64: k = 144: ch = 4
        Case 456: siz = 72: k = 192: ch = 4
        Case 576: siz = 80: k = 224: ch = 4
        Case 696: siz = 88: k = 272: ch = 4
        Case 816: siz = 96: k = 336: ch = 6
        Case 1050: siz = 108: k = 408: ch = 6
        Case 1304: siz = 120: k = 496: ch = 8
        Case 1558: siz = 132: k = 620: ch = 10
      End Select
      If k > 4 Or i > 1558 Then Exit Do
      i = i + 1
      If j = 0 Then encoded1(i) = ((149& * i) Mod 255) + 1 Else encoded1(i) = j Mod 256
      If j <> 0 Then j = Int(j / 256&)
    Loop
    If (i > 1558) Then
      err = "Too big code"
'      setMousePointer(wnd,True)
      Exit Function
    End If
    If siz >= 108 Then
      bl = 6
    ElseIf siz >= 56 Then
      bl = 4
    ElseIf siz >= 28 Then
      bl = 2
    Else
      bl = 1
    End If
    ReDim arr(0)
    ReDim arr(1, siz * 20& + 40& * (bl + 1)) ' 20 bytes per row
    arr(0, 0) = 128
    ' doplnime ECC
    Call dmx_rs(301, encoded1, 0 + i, 0 + k, ch)
'' Call arr2hexstr(encoded1)
    encix(1) = i + k
    dmx_row = 4: dmx_col = 0: i = 1
    Do
      ' only corners cases
      If dmx_can_put(arr, siz, bl, dmx_row, dmx_col, encoded1(i), True) Then i = i + 1
      Do
        If (dmx_row < siz) And (dmx_col >= 0) Then
          If dmx_can_put(arr, siz, bl, dmx_row, dmx_col, encoded1(i), False) Then i = i + 1
        End If
        dmx_row = dmx_row - 2
        dmx_col = dmx_col + 2
        If dmx_row < 0 Or dmx_col >= siz Or i > encix(1) Then Exit Do
      Loop
      dmx_row = dmx_row + 1
      dmx_col = dmx_col + 3
      Do ' downward diagonaly
        If (dmx_row >= 0) And (dmx_col < siz) Then
          If dmx_can_put(arr, siz, bl, dmx_row, dmx_col, encoded1(i), False) Then i = i + 1
        End If
        dmx_row = dmx_row + 2
        dmx_col = dmx_col - 2
        If dmx_row >= siz Or dmx_col < 0 Or i > encix(1) Then Exit Do
      Loop
      dmx_row = dmx_row + 3
      dmx_col = dmx_col + 1
      If (dmx_row >= siz And dmx_col >= siz) Or i > encix(1) Then Exit Do
    Loop
    k = siz * siz
    If (k Mod 8) = 4 Then ' right lower void
      x = dmx_place(arr, siz, bl, siz - 1, siz - 1, 1)
      x = dmx_place(arr, siz, bl, siz - 2, siz - 2, 1)
    End If
    s = Int(siz / bl)
    For i = -1 To s
      For k = 0 To bl ^ 2 - 1
        dmx_col = (k Mod bl) * (s + 2)
        dmx_row = Int(k / bl) * (s + 2)
        x = dmx_place(arr, 0, 0, dmx_row + i, dmx_col - 1, 1) ' leva cara
        x = dmx_place(arr, 0, 0, dmx_row + s, dmx_col + i, 1) ' spodni cara
        If ((i + 2) Mod 2) = 1 Then
          x = dmx_place(arr, 0, 0, dmx_row - 1, dmx_col + i, 1) ' horni tecky
        Else
          x = dmx_place(arr, 0, 0, dmx_row + i, dmx_col + s, 1) ' prave tecky
        End If
      Next
    Next
'    ascimatrix = trim(CStr(siz + 2))
'    ascimatrix = ascimatrix & "x" & ascimatrix & ","
    ascimatrix = ""
    k = siz + 2 * (bl + 1) - 1
    For dmx_row = 0 To k Step 2
      s = 0
      For dmx_col = 0 To k Step 2
        If (dmx_col Mod 8) = 0 Then
          ch = arr(1, s + 20 * dmx_row)
          i = arr(1, s + 20 * (dmx_row + 1))
          s = s + 1
        End If
        ascimatrix = ascimatrix _
           & Chr(97 + (ch Mod 4) + 4 * (i Mod 4))
        ch = Int(ch / 4)
        i = Int(i / 4)
      Next
      ascimatrix = ascimatrix & vbNewLine
    Next dmx_row
    ReDim arr(1, 1)
    dmx_gen = ascimatrix
End Function  ' dmx_gen

Sub qr_rs(ppoly As Integer, pmemptr As Variant, ByVal psize As Integer, ByVal plen As Integer, ByVal pblocks As Integer)
    Dim v_x%, v_y%, v_z%, v_a%, v_b%, pa%, pb%, rp%, v_last%, v_bs%, v_b2c%, vpo%, vdo%, v_es%
    Dim poly(512) As Byte
    Dim v_ply() As Byte
'    Dim dbg$
    ' generate reed solomon expTable and logTable
    '   QR uses GF256(0x11d) // 0x11d=285 => x^8 + x^4 + x^3 + x^2 + 1
    v_x = 1: v_y = 0
    For v_y = 0 To 255
      poly(v_y) = v_x         ' expTable
      poly(v_x + 256) = v_y   ' logTable
      v_x = v_x * 2
      If v_x > 255 Then v_x = v_x Xor ppoly
    Next
'    poly(257) =    ' pro QR logTable(1) = 0 not50
'Call arr2decstr(poly)
    For v_x = 1 To plen
      pmemptr(v_x + psize) = 0
    Next
    v_b2c = pblocks
    ' qr code has first x blocks shorter than lasts
    v_bs = Int(psize / pblocks) ' shorter block size
    v_es = Int(plen / pblocks) ' ecc block size
    v_x = psize Mod pblocks ' remain bytes
    v_b2c = pblocks - v_x ' on block number v_b2c
    ReDim v_ply(v_es + 1)
    v_z = 0 ' pro QR je v_z=0 pro dmx je v_z=1
    v_ply(1) = 1
    v_x = 2
    Do While v_x <= v_es + 1
      v_ply(v_x) = v_ply(v_x - 1)
      v_y = v_x - 1
      Do While v_y > 1
        pb = poly(v_z)
        pa = v_ply(v_y): GoSub rsprod
        v_ply(v_y) = v_ply(v_y - 1) Xor rp
        v_y = v_y - 1
      Loop
      pa = v_ply(1): pb = poly(v_z): GoSub rsprod
      v_ply(1) = rp
      v_z = v_z + 1
      v_x = v_x + 1
    Loop
'Call arr2hexstr(v_ply)
    For v_b = 0 To (pblocks - 1)
      vpo = v_b * v_es + 1 + psize ' ECC start
      vdo = v_b * v_bs + 1 ' data start
      If v_b > v_b2c Then vdo = vdo + v_b - v_b2c ' x longers before
      ' generate "nc" checkwords in the array
      v_x = 0
      v_z = v_bs
      If v_b >= v_b2c Then v_z = v_z + 1
      Do While v_x < v_z
        pa = pmemptr(vpo) Xor pmemptr(vdo + v_x)
        v_y = vpo
        v_a = v_es
        Do While v_a > 0
          pb = v_ply(v_a): GoSub rsprod
          If v_a = 1 Then
            pmemptr(v_y) = rp
          Else
            pmemptr(v_y) = pmemptr(v_y + 1) Xor rp
          End If
          v_y = v_y + 1
          v_a = v_a - 1
        Loop
        v_x = v_x + 1
'if v_b = 0 and v_x = v_z then call arr2hexstr(pmemptr)
      Loop
    Next
    Exit Sub
rsprod:
    rp = 0
    If pa > 0 And pb > 0 Then rp = poly((0& + poly(256 + pa) + poly(256 + pb)) Mod 255&)
    Return
End Sub ' reed solomon qr_rs

''' <summary>
''' QRコード用のビット配列を設定するSubプロシージャ
''' </summary>
''' <param name="NumvarAryParrber"></param>
''' <remarks></remarks>
'
' 結果を格納する配列
' ビット挿入位置
' 挿入する値
' 挿入するビットの長さ
Sub subBb_PutBits( _
    ByRef varAryParr As Variant, _
    ByRef intParrPosition As Integer, _
    varPa As Variant, _
    ByVal intPaLength As Integer _
    )

    Dim intIndex%, intBit%, intResult&, intLength%, intLoopIndex%
    Dim dblWork As Double
    Dim byteAryTemp(7) As Byte ' 一時的なバイト配列
    Dim varAryInput As Variant

    ' 入力値の型を確認する
    intResult = VarType(varPa)
    If intResult = 17 Or intResult = 2 Or intResult = 3 Or intResult = 5 Then ' byte, integer, long, double 型の場合
        If intPaLength > 56 Then Exit Sub ' 長さが制限を超えた場合処理を終了
        dblWork = varPa
        intLength = intPaLength
        If intLength < 56 Then dblWork = dblWork * 2 ^ (56 - intLength)

        intIndex = 0
        ' 値をバイト単位で分解
        Do While intIndex < 6 And dblWork > 0#
            intResult = Int(dblWork / 2 ^ 48)
            byteAryTemp(intIndex) = intResult Mod 256
            dblWork = dblWork - 2 ^ 48 * intResult
            dblWork = dblWork * 256
            intLength = intLength - 8
            intIndex = intIndex + 1
        Loop
        varAryInput = byteAryTemp
    ElseIf InStr("Integer(),Byte(),Long(),Variant()", TypeName(varPa)) > 0 Then
        varAryInput = varPa ' 直接配列として使用
    Else
        MsgBox TypeName(varPa), "Unknown type" ' 未知の型の場合エラーメッセージ
        Exit Sub
    End If

    ' 配列へのビット挿入
    intIndex = Int(intParrPosition / 8) + 1
    intBit = intParrPosition Mod 8
    intLoopIndex = LBound(varAryInput)
    intLength = intPaLength

    Do While intLength > 0
        If intLoopIndex <= UBound(varAryInput) Then
            intResult = varAryInput(intLoopIndex)
            intLoopIndex = intLoopIndex + 1
        Else
            intResult = 0 ' 終端の場合は0を挿入
        End If

        If (intLength < 8) Then intResult = intResult And (256 - 2 ^ (8 - intLength))
        If intBit > 0 Then
            intResult = intResult * 2 ^ (8 - intBit)
            varAryParr(intIndex) = varAryParr(intIndex) Or Int(intResult / 256)
            varAryParr(intIndex + 1) = varAryParr(intIndex + 1) Or (intResult And 255)
        Else
            varAryParr(intIndex) = varAryParr(intIndex) Or (intResult And 255)
        End If

        If intLength < 8 Then
            intParrPosition = intParrPosition + intLength
            intLength = 0
        Else
            intParrPosition = intParrPosition + 8
            intIndex = intIndex + 1
            intLength = intLength - 8
        End If
    Loop
End Sub

Function qr_numbits(ByVal num As Long) As Integer
  Dim n%, a&
  a = 1: n = 0
  Do While a <= num
    a = a * 2
    n = n + 1
  Loop
  qr_numbits = n
End Function

' padding 0xEC,0x11,0xEC,0x11...
' TYPE_INFO_MASK_PATTERN = 0x5412
' TYPE_INFO_POLY = 0x537  [(ecLevel << 3) | maskPattern] : 5 + 10 = 15 bitu
' VERSION_INFO_POLY = 0x1f25 : 5 + 12 = 17 bitu
Sub qr_bch_calc(ByRef data As Long, ByVal poly As Long)
  Dim b%, n%, rv&, x&
  b = qr_numbits(poly) - 1
  If data = 0 Then
'    data = poly
    Exit Sub
  End If
  x = data * 2 ^ b
  rv = x
  Do
    n = qr_numbits(rv)
    If n <= b Then Exit Do
    rv = rv Xor (poly * 2 ^ (n - b - 1))
  Loop
  data = x + rv
End Sub

Sub qr_params(ByVal pcap As Long, ByVal ecl As Integer, ByRef rv As Variant, ByRef ecx_poc As Variant)
  Dim siz%, totby&, s$, i&, syncs%, ccsiz%, ccblks%, j&, ver%
'  Dim rv(15) as Integer ' 1:version,2:size,3:ccs,4:ccb,5:totby,6-12:syncs(7),13-15:versinfo(3)
'  ecl:M=0,L=1,H=2,Q=3
  If ecl < 0 Or ecl > 3 Then Exit Sub
  For i = 1 To UBound(rv): rv(i) = 0: Next i
  j = Int((pcap + 18 * ecx_poc(1) + 17 * ecx_poc(2) + 20 * ecx_poc(3) + 7) / 8)
  If ecl = 0 And j > 2334 Or _
     ecl = 1 And j > 2956 Or _
     ecl = 2 And j > 1276 Or _
     ecl = 3 And j > 1666 Then
    Exit Sub
  End If
  j = Int((pcap + 14 * ecx_poc(1) + 13 * ecx_poc(2) + 12 * ecx_poc(3) + 7) / 8)
  For ver = 1 To 40
    If ver = 10 Then j = Int((pcap + 16 * ecx_poc(1) + 15 * ecx_poc(2) + 20 * ecx_poc(3) + 7) / 8)
    If ver = 27 Then j = Int((pcap + 18 * ecx_poc(1) + 17 * ecx_poc(2) + 20 * ecx_poc(3) + 7) / 8)
    siz = 4 * ver + 17
    i = (ver - 1) * 12 + ecl * 3
    s = Mid("D01A01K01G01J01D01V01P01T01I01P02L02L02N01J04T02R02T01P04L04J04L02V04R04L04N02T05L06P04R02T06P06P05X02R08N08T05L04V08R08X05N04R11V08P08R04V11T10P09T04P16R12R09X04R16N16R10P06R18X12V10R06X16R17V11V06V19V16T13X06V21V18T14V07T25T21T16V08V25X20T17V08X25V23V17V09R34X23V18X09X30X25V20X10X32X27V21T12X35X29V23V12X37V34V25X12X40X34V26X13X42X35V28X14X45X38V29X15X48X40V31X16X51X43V33X17X54X45V35X18X57X48V37X19X60X51V38X19X63X53V40X20X66X56V43X21X70X59V45X22X74X62V47X24X77X65V49X25X81X68" _
            , i + 1, 3)
    ccsiz = AscL(Left(s, 1)) - 65 + 7
    ccblks = Val(Right(s, 2))
    If ver = 1 Then
      syncs = 0
      totby = 26
    Else
      syncs = ((Int(ver / 7) + 2) ^ 2) - 3
      totby = siz - 1
      totby = ((totby ^ 2) / 8) - (3& * syncs) - 24
      If ver > 6 Then totby = totby - 4
      If syncs = 1 Then totby = totby - 1
    End If
'MsgBox "ver:" & ver & " tot: " & totby & " dat:" & (totby - ccsiz * ccblks) & " need:" & j
    If totby - ccsiz * ccblks >= j Then Exit For
  Next
  If ver > 1 Then
    syncs = Int(ver / 7) + 2
    rv(6) = 6
    rv(5 + syncs) = siz - 7
    If syncs > 2 Then
      i = Int((siz - 13) / 2 / (syncs - 1) + 0.7) * 2
      rv(7) = rv(5 + syncs) - i * (syncs - 2)
      If syncs > 3 Then
        For j = 3 To syncs - 1
          rv(5 + j) = rv(4 + j) + i
        Next
      End If
    End If
  End If
  rv(1) = ver
  rv(2) = siz
  rv(3) = ccsiz: rv(4) = ccblks
  rv(5) = totby
  If ver >= 7 Then
    i = ver
    Call qr_bch_calc(i, &H1F25)
    rv(13) = Int(i / 65536)
    rv(14) = Int(i / 256&) Mod 256
    rv(15) = i Mod 256
  End If
End Sub


''' <summary>
''' QRコードの指定位置のビット操作を行う関数
''' </summary>
''' <param name="varParr">ビット操作を行う配列</param>
''' <param name="intPsiz">操作サイズ（正の場合は設定、負の場合はマスク）</param>
''' <param name="intProw">行位置</param>
''' <param name="intPcol">列位置</param>
''' <param name="intPbit">設定するビットの値</param>
''' <returns>ビット操作が成功したかどうかの真偽値</returns>
Function fncQRBit( _
    varParr As Variant, _
    ByVal intPsiz As Integer, _
    ByVal intProw As Integer, _
    ByVal intPcol As Integer, _
    ByVal intPbit As Integer _
    ) As Boolean

    Dim intIndex%, intVa%, intRow%, intCol%, intTemp%
    intRow = intProw
    intCol = intPcol
    fncQRBit = False

    ' 行・列から配列のインデックスを計算
    intIndex = intRow * 24 + Int(intCol / 8) ' 各行24バイト
    If intIndex > (UBound(varParr, 2)) Or intIndex < 0 Then Exit Function

    intCol = 2 ^ (intCol Mod 8) ' ビット位置を計算
    intVa = varParr(0, intIndex)

    If intPsiz > 0 Then ' 操作サイズが正の場合（ビットセット）
        If (intVa And intCol) = 0 Then
            If intPbit <> 0 Then varParr(1, intIndex) = varParr(1, intIndex) Or intCol
            fncQRBit = True
        Else
            fncQRBit = False
        End If
    Else
        ' 操作サイズが負またはゼロの場合
        fncQRBit = True
        varParr(1, intIndex) = varParr(1, intIndex) And (255 - intCol) ' ビットリセット
        If intPbit > 0 Then varParr(1, intIndex) = varParr(1, intIndex) Or intCol
        If intPsiz < 0 Then varParr(0, intIndex) = varParr(0, intIndex) Or intCol ' マスク操作
    End If
End Function

''' <summary>
''' QRコードのビット配列に値を挿入します
''' </summary>
''' <param name="varParr">QRコードのビット配列</param>
''' <param name="varPb">挿入する値（単一値または配列）</param>
''' <param name="intBits">ビット幅</param>
''' <param name="intRow">開始行</param>
''' <param name="intColumn">開始列</param>
''' <remarks>最大ビット幅は8ビットです</remarks>
Sub subQRMask( _
    varParr As Variant, _
    varPb As Variant, _
    ByVal intBits As Integer, _
    ByVal intRow As Integer, _
    ByVal intColumn As Integer _
    )

    Dim intIndex%, intVar%, intRowPosition%, intColPosition%, intLoopIndex%
    Dim boolTemp As Boolean

    ' 最大ビット幅のチェック
    If intBits > 8 Or intBits < 1 Then Exit Sub

    intRowPosition = intRow
    intColPosition = intColumn
    intVar = VarType(varPb)

    ' 挿入する値が特定の型の場合の処理
    If intVar = 17 Or intVar = 2 Or intVar = 3 Or intVar = 5 Then ' byte, integer, long, double 型
        intVar = Int(varPb)
        intIndex = 2 ^ (intBits - 1)
        Do While intIndex > 0
            boolTemp = fncQRBit(varParr, -1, intRowPosition, intColPosition, intVar And intIndex)
            intColPosition = intColPosition + 1
            intIndex = Int(intIndex / 2)
        Loop
    ElseIf InStr("Integer(),Byte(),Long(),Variant()", TypeName(varPb)) > 0 Then
        ' 配列の場合の処理
        For intLoopIndex = LBound(varPb) To UBound(varPb)
            intVar = Int(varPb(intLoopIndex))
            intIndex = 2 ^ (intBits - 1)
            intColPosition = intColumn
            Do While intIndex > 0
                boolTemp = fncQRBit(varParr, -1, intRowPosition, intColPosition, intVar And intIndex)
                intColPosition = intColPosition + 1
                intIndex = Int(intIndex / 2)
            Loop
            intRowPosition = intRowPosition + 1
        Next
    End If
End Sub

Sub qr_fill(parr As Variant, ByVal psiz%, pb As Variant, ByVal pblocks As Integer, ByVal pdlen As Integer, ByVal ptlen As Integer)
  ' vyplni pole parr (psiz x 24 bytes) z pole pb pdlen = pocet dbytes, pblocks = bloku, ptlen celkem
  ' podle logiky qr_kodu - s prokladem
  Dim vx%, vb%, vy%, vdnlen%, vds%, ves%, c%, r%, wa%, wb%, w%, smer%, vsb%
  ' qr code has first x blocks shorter than lasts but datamatrix has first longer and shorter last
  vds = Int(pdlen / pblocks) ' shorter data block size
  ves = Int((ptlen - pdlen) / pblocks) ' ecc block size
  vdnlen = vds * pblocks ' potud jsou databloky stejne velike
  vsb = pblocks - (pdlen Mod pblocks) ' mensich databloku je ?
  
  c = psiz - 1: r = c ' start position on right lower corner
  smer = 0 ' nahoru :  3 <- 2 10  dolu: 1 <- 0  32
           '           1 <- 0 10        3 <- 2  32
  vb = 1: w = pb(1): vx = 0
  Do While c >= 0 And vb <= ptlen
    If fncQRBit(parr, psiz, r, c, (w And 128)) Then
      vx = vx + 1
      If vx = 8 Then
        GoSub qrfnb ' first byte
        vx = 0
      Else
        w = (w * 2) Mod 256
      End If
    End If
    Select Case smer
      Case 0, 2 ' nahoru nebo dolu a jsem vpravo
        c = c - 1
        smer = smer + 1
      Case 1 ' nahoru a jsem vlevo
        If r = 0 Then ' nahoru uz to nejde
          c = c - 1
          If c = 6 And psiz >= 21 Then c = c - 1 ' preskoc sync na sloupci 6
          smer = 2 ' a jedeme dolu
        Else
          c = c + 1
          r = r - 1
          smer = 0 ' furt nahoru
        End If
      Case 3 ' dolu a jsem vlevo
        If r = (psiz - 1) Then ' dolu uz to nepude
          c = c - 1
          If c = 6 And psiz >= 21 Then c = c - 1 ' preskoc sync na sloupci 6
          smer = 0
        Else
          c = c + 1
          r = r + 1
          smer = 2
        End If
    End Select
  Loop
  Exit Sub
qrfnb:
  ' next byte
        ' plen = 14 pbl = 3   => 1x4 + 2x5 (v_b2c = 3 - 2 = 1; v_bs1 = 4)
        '     v_b = 0 => v_last = 0 + 4 * 3 - 2 = 10 => 1..12 by 3   1,4,7,10
        '     v_b = 1 => v_last = 1 + 4 * 3     = 13 => 2..13 by 3   2,5,8,11,13
        '     v_b = 2 => v_last = 2 + 4 * 3     = 14 => 3..14 by 3   3,6,9,12,14
        ' plen = 15 pbl = 3   => 3x5 (v_b2c = 3; v_bs1 = 5)
        '     v_b = 0 => v_last = 0 + 5 * 3 - 2 = 13 => 1..13 by 3   1,4,7,10,13
        '     v_b = 1 => v_last = 1 + 5 * 3 - 2 = 14 => 2..14 by 3   2,5,8,11,14
        '     v_b = 2 => v_last = 2 + 5 * 3 - 2 = 15 => 3..15 by 3   3,6,9,12,15
  If vb < pdlen Then ' Datovy byte
    wa = vb
    If vb >= vdnlen Then
      wa = wa + vsb
    End If
    wb = wa Mod pblocks
    wa = Int(wa / pblocks)
    If wb > vsb Then wa = wa + wb - vsb
'    If vb >= vdnlen Then MsgBox "D:" & (1 + vds * wb + wa)
    w = pb(1 + vds * wb + wa)
  ElseIf vb < ptlen Then ' ecc byte
    wa = vb - pdlen ' kolikaty ecc 0..x
    wb = wa Mod pblocks ' z bloku
    wa = Int(wa / pblocks) ' kolikaty
'    MsgBox "E:" & (1 + pdlen + ves * wb + wa)
    w = pb(1 + pdlen + ves * wb + wa)
  End If
  vb = vb + 1
  Return
End Sub

' Black If 0: (c+r) mod 2 = 0    4: ((r div 2) + (c div 3)) mod 2 = 0
'          1: r mod 2 = 0        5: (c*r) mod 2 + (c*r) mod 3 = 0
'          2: c mod 3 = 0        6: ((c*r) mod 2 + (c*r) mod 3) mod 2 = 0
'          3: (c+r) mod 3 = 0    7: ((c+r) mod 2 + (c*r) mod 3) mod 2 = 0
Function qr_xormask(parr As Variant, ByVal siz As Integer, ByVal pmod As Integer, ByVal final As Boolean) As Long
  Dim score&, bl&, rp&, rc&, c%, r%, m%, ix%, i%, w%
  Dim warr() As Byte
  Dim cols() As Long
  
  ReDim warr(siz * 24)
  For r = 0 To siz - 1
    m = 1
    ix = 24 * r
    warr(ix) = parr(1, ix)
    For c = 0 To siz - 1
      If (parr(0, ix) And m) = 0 Then ' nemaskovany
        Select Case pmod
         Case 0: i = (c + r) Mod 2
         Case 1: i = r Mod 2
         Case 2: i = c Mod 3
         Case 3: i = (c + r) Mod 3
         Case 4: i = (Int(r / 2) + Int(c / 3)) Mod 2
         Case 5: i = (c * r) Mod 2 + (c * r) Mod 3
         Case 6: i = ((c * r) Mod 2 + (c * r) Mod 3) Mod 2
         Case 7: i = ((c + r) Mod 2 + (c * r) Mod 3) Mod 2
        End Select
        If i = 0 Then warr(ix) = warr(ix) Xor m
      End If
      If m = 128 Then
        m = 1
        If final Then parr(1, ix) = warr(ix)
        ix = ix + 1
        warr(ix) = parr(1, ix)
      Else
        m = m * 2
      End If
    Next c
    If m <> 128 And final Then parr(1, ix) = warr(ix)
  Next r
  If final Then
    qr_xormask = 0
    Exit Function
  End If
 ' score computing
 ' a) adjacent modules colors in row or column 5+i mods = 3 + i penatly
 ' b) block same color MxN = 3*(M-1)*(N-1) penalty OR every 2x2 block penalty + 3
 ' c) 4:1:1:3:1:1 or 1:1:3:1:1:4 in row or column = 40 penalty rmks: 00001011101 or 10111010000 = &H05D or &H5D0
 ' d) black/light ratio : k=(abs(ratio% - 50) DIV 5) means 10*k penalty
  score = 0: bl = 0
'Dim s(4) as Integer
  ReDim cols(1, siz)
  rp = 0: rc = 0
  For r = 0 To siz - 1
    m = 1
    ix = 24 * r
    rp = 0: rc = 0
    For c = 0 To siz - 1
      rp = (rp And &H3FF) * 2 ' only last 12 bits
      cols(1, c) = (cols(1, c) And &H3FF) * 2
      If (warr(ix) And m) <> 0 Then
        If rc < 0 Then ' in row x whites
          If rc <= -5 Then score = score - 2 - rc  ': s(0) = s(0) - 2 - rc
          rc = 0
        End If
        rc = rc + 1 ' one more black
        If cols(0, c) < 0 Then ' color changed
          If cols(0, c) <= -5 Then score = score - 2 - cols(0, c) ': s(1) = s(1) - 2 - cols(0,c)
          cols(0, c) = 0
        End If
        cols(0, c) = cols(0, c) + 1 ' one more black
        rp = rp Or 1
        cols(1, c) = cols(1, c) Or 1
        bl = bl + 1 ' balck modules count
      Else
        If rc > 0 Then ' in row x black
          If rc >= 5 Then score = score - 2 + rc ': s(0) = s(0) - 2 + rc
          rc = 0
        End If
        rc = rc - 1 ' one more white
        If cols(0, c) > 0 Then ' color changed
          If cols(0, c) >= 5 Then score = score - 2 + cols(0, c) ': s(1) = s(1) - 2 + cols(0,c)
          cols(0, c) = 0
        End If
        cols(0, c) = cols(0, c) - 1 ' one more white
      End If
      If c > 0 And r > 0 Then ' penalty block 2x2
        i = rp And 3 ' current row pair
        If (cols(1, c - 1) And 3) >= 2 Then i = i + 8
        If (cols(1, c) And 3) >= 2 Then i = i + 4
        If i = 0 Or i = 15 Then
          score = score + 3 ': s(2) = s(2) + 3
          ' b) penalty na 2x2 block same color
        End If
      End If
      If c >= 10 And (rp = &H5D Or rp = &H5D0) Then  ' penalty pattern c in row
        score = score + 40 ': s(3) = s(3) + 40
      End If
      If r >= 10 And (cols(1, c) = &H5D Or cols(1, c) = &H5D0) Then ' penalty pattern c in column
        score = score + 40 ': s(3) = s(3) + 40
      End If
      ' next mask / byte
      If m = 128 Then
        m = 1
        ix = ix + 1
      Else
        m = m * 2
      End If
    Next
    If rc <= -5 Then score = score - 2 - rc ': s(0) = s(0) - 2 - rc
    If rc >= 5 Then score = score - 2 + rc ': s(0) = s(0) - 2 + rc
  Next
  For c = 0 To siz - 1 ' after last row count column blocks
    If cols(0, c) <= -5 Then score = score - 2 - cols(0, c) ': s(1) = s(1) - 2 - cols(0,c)
    If cols(0, c) >= 5 Then score = score - 2 + cols(0, c) ': s(1) = s(1) - 2 + cols(0,c)
  Next
  bl = Int(Abs((bl * 100&) / (siz * siz) - 50&) / 5) * 10
'MsgBox "mask:" + pmod + " " + s(0) + "+" + s(1) + "+" + s(2) + "+" + s(3) + "+" + bl
  qr_xormask = score + bl
End Function


    
'QRコード生成用関数
'UTF-8文字列を処理し、QRコードの生成に必要なデータを作成します
'''UTF8:"UCS Transformation Format 8","Unicode Transformation Format-8"
'''<return>
'''生成されたQRコードを表すASCII文字列
'''</return>
Function fncQR_Gen( _
    strPtext As String _
    , strP_Options As String _
    ) As String
    
    ' エンコードされたデータ（バイト配列）を格納
    ' byte mode (ASCII) all max 3200 bytes
    Dim bytAryEncoded1() As Byte
    'エンコードデータのインデックス
    Dim intEncix1 As Integer
    '' エラー訂正ブロックのカウント
    Dim intAryEcx_Cnt(3) As Integer
    'エラー訂正ブロックの位置
    Dim intAryEcx_Pos(3) As Integer
    'エラー訂正ブロックのポインタ
    Dim intAryEcx_Poc(3) As Integer
    'エラー訂正データの格納用配列
    Dim intAryEB(20, 4) As Integer
    
    'エンコードデータ用の文字列
    Dim strAsciMatrix As String
    'モード
    Dim strMode As String
    'エラーメッセージ
    Dim strErrorMessage As String
    'QRコード生成に関するフラグやカウンタ変数
    Dim lngEcl As Long
    Dim lngR As Long
    Dim c%
    Dim lngMask As Long
    Dim utf8 As Long
    Dim lngEBcnt As Long
    
    '汎用カウンタ変数
    Dim lngI As Long
    Dim j As Long
    Dim lngK As Long
    Dim lngM As Long
    
    '文字コード、データサイズなどの計算用変数
    Dim ch%
    Dim s%
    Dim siz%
    'フラグ変数
    Dim blnX As Boolean
    
    '最終的なQRコードのマトリクス
    Dim bytAryQR() As Byte ' final matrix
    'QRコードマトリクス内の位置ポインタ
    'Dim intAryQRPos As Integer
    
    
    ' QRコードに関する情報を格納する配列
    'QRコードのバージョン、サイズ、エラー訂正レベルなどの情報
    ' 1:version,2:size,3:ccs,4:ccb,5:totby,6-12:syncs(7),13-15:versinfo(3)
    Dim intAryQRParam(15) As Integer
    
    'QRコード同期パターン1
    Dim bytAryQrsync1(1 To 8) As Byte
    'QRコード同期パターン2
    Dim bytAryQrsync2(1 To 5) As Byte
    
    '' 初期化：エンコードマトリクスを空に設定
    strAsciMatrix = ""
    '' 初期化：エラーメッセージを空に設定
    strErrorMessage = ""
    '' デフォルトのモードを "M" に設定
    strMode = "M"
    
    ' オプションからモードを検索
    '"strMode=" の次の文字をモードとして取得
    lngI = InStr(strP_Options, "mode=")
    If lngI > 0 Then strMode = Mid(strP_Options, lngI + 5, 1)
    
    ' モードに対応するエラー訂正レベルを計算
    'M=0 (通常), L=1 (低エラー), H=2 (高エラー), Q=3 (中エラー)
    lngEcl = InStr("MLHQ", strMode) - 1
    ' 無効なモードの場合、デフォルトを適用
    If lngEcl < 0 Then strMode = "M": lngEcl = 0
    
    '' 入力データが空の場合はエラーメッセージを設定して終了
    If strPtext = "" Then
        strErrorMessage = "Not data"
        Exit Function
    End If
        
    'エラー訂正ブロック関連の初期化
    For lngI = 1 To 3
        ' ブロック位置を初期化
        intAryEcx_Pos(lngI) = 0
        ' ブロックカウントを初期化
        intAryEcx_Cnt(lngI) = 0
        ' ブロックポインタを初期化
        intAryEcx_Poc(lngI) = 0
    Next lngI
    
    ' エラー訂正ブロックのカウンタを初期化
    lngEBcnt = 1
    ' UTF-8エンコードされたバイト数を保持する変数を初期化
    utf8 = 0
    
    Dim strChar As String
    '入力されたテキスト文字列をループして処理
    For lngI = 1 To Len(strPtext) + 1
        If lngI > Len(strPtext) Then
            ' テキストの終端に到達した場合、終了処理用の値を設定
            lngK = -5
        Else
            
            ' 現在の文字のUnicodeコードポイントを取得
            lngK = AscL(Mid(strPtext, lngI, 1))
            strChar = Mid(strPtext, lngI, 1)
            Debug.Print ("qr_gen.AscL " & strChar & "(" & CStr(Hex(lngK)) & ")")
            '全角文字の、「AscW」でマイナス値が返って来た
            ' Unicodeが負の場合の処理（全角文字の場合など）
            If lngK < 0 Then
                lngK = lngK + 65536
            End If
            ' 各Unicodeコードポイントに応じてエンコード方法を判定
            If lngK >= &H1FFFFF Then ' FFFF - 1FFFFFFF
                ' 4バイト以上:絵文字、一部のCJK拡張文字など
                lngM = 4
                lngK = -1
            ElseIf lngK >= &H7FF Then ' 7FF-FFFF 3 bytes
                ' 3バイト:ほとんどの日本語文字、記号など 例:漢(6F22)
                lngM = 3
                lngK = -1
            ElseIf lngK >= 128 Then
                ' 2バイトで表現される文字
                lngM = 2
                lngK = -1
            Else
                '1バイト:ASCII文字 (A-Z, a-z, 0-9, 記号など) や制御文字など 例 9(39) a(61)
                lngM = 1
                ' QRコードの英数字モード対応
                lngK = InStr(qralnum, Mid(strPtext, lngI, 1)) - 1
            End If
            
        End If
        
        ' エンコードデータが特定の条件を満たす場合、適切な処理を実行
        
        ' バイトモードまたは終了処理の条件
        If (lngK < 0) Then
            ' bude byte nebo konec
            ' Numericモードの処理や条件判定
            ' AlphanumericモードとByteモードで切り替える
            ' 必要に応じてエラー訂正ブロックの種類や位置を登録
            If intAryEcx_Cnt(1) >= 9 Or (lngK = -5 And intAryEcx_Cnt(1) = intAryEcx_Cnt(3)) Then ' Az dosud bylo mozno pouzitelne numeric
                If (intAryEcx_Cnt(2) - intAryEcx_Cnt(1)) >= 8 Or (intAryEcx_Cnt(3) = intAryEcx_Cnt(2)) Then ' pred num je i pouzitelny alnum
                    If (intAryEcx_Cnt(3) > intAryEcx_Cnt(2)) Then ' Jeste pred alnum bylo byte
                        intAryEB(lngEBcnt, 1) = 3         ' Typ byte
                        intAryEB(lngEBcnt, 2) = intAryEcx_Pos(3) ' pozice
                        intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(3) - intAryEcx_Cnt(2) ' delka
                        lngEBcnt = lngEBcnt + 1
                        intAryEcx_Poc(3) = intAryEcx_Poc(3) + 1
                    End If
                    intAryEB(lngEBcnt, 1) = 2         ' Typ alnum
                    intAryEB(lngEBcnt, 2) = intAryEcx_Pos(2)
                    intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(2) - intAryEcx_Cnt(1) ' delka
                    lngEBcnt = lngEBcnt + 1
                    intAryEcx_Poc(2) = intAryEcx_Poc(2) + 1
                    intAryEcx_Cnt(2) = 0
                ElseIf intAryEcx_Cnt(3) > intAryEcx_Cnt(1) Then ' byly bytes pred numeric
                    intAryEB(lngEBcnt, 1) = 3         ' Typ byte
                    intAryEB(lngEBcnt, 2) = intAryEcx_Pos(3) ' pozice
                    intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(3) - intAryEcx_Cnt(1) ' delka
                    lngEBcnt = lngEBcnt + 1
                    intAryEcx_Poc(3) = intAryEcx_Poc(3) + 1
                End If
            ElseIf (intAryEcx_Cnt(2) >= 8) Or (lngK = -5 And intAryEcx_Cnt(2) = intAryEcx_Cnt(3)) Then ' Az dosud bylo mozno pouzitelne alnum
                If (intAryEcx_Cnt(3) > intAryEcx_Cnt(2)) Then ' Jeste pred alnum bylo byte
                    intAryEB(lngEBcnt, 1) = 3         ' Typ byte
                    intAryEB(lngEBcnt, 2) = intAryEcx_Pos(3) ' pozice
                    intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(3) - intAryEcx_Cnt(2) ' delka
                    lngEBcnt = lngEBcnt + 1
                    intAryEcx_Poc(3) = intAryEcx_Poc(3) + 1
                End If
                intAryEB(lngEBcnt, 1) = 2         ' Typ alnum
                intAryEB(lngEBcnt, 2) = intAryEcx_Pos(2)
                intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(2) ' delka
                lngEBcnt = lngEBcnt + 1
                intAryEcx_Poc(2) = intAryEcx_Poc(2) + 1
                intAryEcx_Cnt(3) = 0
                intAryEcx_Cnt(2) = 0 ' vse zpracovano
            ElseIf (lngK = -5 And intAryEcx_Cnt(3) > 0) Then ' konec ale mam co ulozit
                intAryEB(lngEBcnt, 1) = 3         ' Typ byte
                intAryEB(lngEBcnt, 2) = intAryEcx_Pos(3) ' pozice
                intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(3) ' delka
                lngEBcnt = lngEBcnt + 1
                intAryEcx_Poc(3) = intAryEcx_Poc(3) + 1
            End If
        End If
      
        'テキストの終了条件
        If lngK = -5 Then Exit For
        
        ' 数値モードのエンコード処理
        If (lngK >= 0) Then ' Muzeme alnum
            ' Alphanumericモード
            ' Alphanumericとしてブロックを登録
            If (lngK >= 10 And intAryEcx_Cnt(1) >= 12) Then ' Az dosud bylo mozno num
                  ' Je tam i alnum ktery stoji za to
                If (intAryEcx_Cnt(2) - intAryEcx_Cnt(1)) >= 8 Or (intAryEcx_Cnt(3) = intAryEcx_Cnt(2)) Then
                    If (intAryEcx_Cnt(3) > intAryEcx_Cnt(2)) Then ' Jeste pred alnum bylo byte
                        intAryEB(lngEBcnt, 1) = 3         ' Typ byte
                        intAryEB(lngEBcnt, 2) = intAryEcx_Pos(3) ' pozice
                        intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(3) - intAryEcx_Cnt(2) ' delka
                        lngEBcnt = lngEBcnt + 1
                        intAryEcx_Poc(3) = intAryEcx_Poc(3) + 1
                    End If
                    intAryEB(lngEBcnt, 1) = 2         ' Typ alnum
                    intAryEB(lngEBcnt, 2) = intAryEcx_Pos(2)
                    intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(2) - intAryEcx_Cnt(1) ' delka
                    lngEBcnt = lngEBcnt + 1
                    intAryEcx_Poc(2) = intAryEcx_Poc(2) + 1
                    intAryEcx_Cnt(2) = 0 ' vse zpracovano
                ElseIf (intAryEcx_Cnt(3) > intAryEcx_Cnt(1)) Then ' Pred Num je byte
                    intAryEB(lngEBcnt, 1) = 3         ' Typ byte
                    intAryEB(lngEBcnt, 2) = intAryEcx_Pos(3) ' pozice
                    intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(3) - intAryEcx_Cnt(1) ' delka
                    lngEBcnt = lngEBcnt + 1
                    intAryEcx_Poc(3) = intAryEcx_Poc(3) + 1
                End If
                intAryEB(lngEBcnt, 1) = 1         ' Typ numerix
                intAryEB(lngEBcnt, 2) = intAryEcx_Pos(1)
                intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(1) ' delka
                lngEBcnt = lngEBcnt + 1
                intAryEcx_Poc(1) = intAryEcx_Poc(1) + 1
                intAryEcx_Cnt(1) = 0
                intAryEcx_Cnt(2) = 0
                intAryEcx_Cnt(3) = 0 ' vse zpracovano
            End If
            If intAryEcx_Cnt(2) = 0 Then intAryEcx_Pos(2) = lngI
            intAryEcx_Cnt(2) = intAryEcx_Cnt(2) + 1
        Else ' mozno alnum
            ' Alphanumericモードをリセット
            intAryEcx_Cnt(2) = 0
        End If
      
        ' 数値モードのブロックが続く場合の登録
        ' Numericモード
        If lngK >= 0 And lngK < 10 Then ' muze byt numeric
            ' Numericとしてブロックを登録
            If intAryEcx_Cnt(1) = 0 Then intAryEcx_Pos(1) = lngI
            intAryEcx_Cnt(1) = intAryEcx_Cnt(1) + 1
        Else
            ' Numericモードをリセット
            intAryEcx_Cnt(1) = 0
        End If
        
        ' Byteモードに対するデータの長さと位置を記録
        If intAryEcx_Cnt(3) = 0 Then intAryEcx_Pos(3) = lngI
        ' バイト数を累計
        intAryEcx_Cnt(3) = intAryEcx_Cnt(3) + lngM
        ' 総バイト数を更新
        utf8 = utf8 + lngM
        
        ' エラー訂正ブロックの容量制限
        If lngEBcnt >= 16 Then ' Uz by se mi tri dalsi bloky stejne nevesli
          intAryEcx_Cnt(1) = 0
          intAryEcx_Cnt(2) = 0
        End If
        'MsgBox "Znak:" & Mid(strPtext,i,1) & "(" & lngK & ") ebn=" & intAryEcx_Pos(1) _
        & "." & intAryEcx_Cnt(1) & " eba=" & intAryEcx_Pos(2) & "." & intAryEcx_Cnt(2) & " ebb=" & intAryEcx_Pos(3) & "." & intAryEcx_Cnt(3)
    Next
    
    ' 各エラー訂正ブロックを処理して必要なデータサイズを計算
    lngEBcnt = lngEBcnt - 1
    
    '----From https://github.com/JonasHeidelberg/barcode-vba-macro-only --- Begin ---
    
     Dim current_mode ' ECI mode that current substring will be encoded in
 
      ' **** Since the code above is known to be buggy, but difficult
    ' **** to understand, add a "safety net" here doing some
    ' **** plausibility checks and trying to fix known error that
    ' **** might have been made above
    ' **1) Check that eb() rows cover the full string (i.e. last eb row is not missing)
    If (intAryEB(lngEBcnt, 2) + intAryEB(lngEBcnt, 3) < (Len(strPtext) + 1)) Then
        ' oops, eb() does not cover full text. Lets hope the code above just forgot to add the last row
        If (intAryEcx_Pos(1) = intAryEB(lngEBcnt, 2) + intAryEB(lngEBcnt, 3)) Then ' This is a quick fix. Not well tested.
            current_mode = 1
        Else
            If (intAryEcx_Pos(2) = intAryEB(lngEBcnt, 2) + intAryEB(lngEBcnt, 3)) Then ' This is only a guess. Not tested at all. Sorry ;-)
                current_mode = 2
            Else
                current_mode = 3
            End If
        End If
        lngEBcnt = lngEBcnt + 1
        intAryEB(lngEBcnt, 1) = current_mode
        intAryEB(lngEBcnt, 2) = intAryEcx_Pos(current_mode)
        intAryEB(lngEBcnt, 3) = intAryEcx_Cnt(current_mode)
        intAryEcx_Poc(current_mode) = intAryEcx_Poc(current_mode) + 1
    End If
    ' **2) Check that eb() rows are non-overlapping
    For j = 1 To lngEBcnt
    
         Debug.Print (j & ". (" & Mid("NAB", intAryEB(j, 1), 1) & "): '" & Replace(Mid(strPtext, intAryEB(j, 2), intAryEB(j, 3)), Chr(10), "\n") & "'")
    Next j
    
    Dim wasfixed As Boolean
    Dim i As Long
    i = 1
    Dim k As Long
    While i < (lngEBcnt - 1)
    If intAryEB(i, 2) + intAryEB(i, 3) <> intAryEB(i + 1, 2) Then
        ' oops, this should not happen. First document it:
        Debug.Print ("intAryEB() rows " & i & " and " & i + 1 & " are overlapping:")
        For j = 1 To lngEBcnt
            If i = j Then
                Debug.Print (intAryEB(j, 1) & ": " & intAryEB(j, 2) & " ... " & intAryEB(j, 2) + intAryEB(j, 3)) & " :-("
            Else
                Debug.Print (intAryEB(j, 1) & ": " & intAryEB(j, 2) & " ... " & intAryEB(j, 2) + intAryEB(j, 3))
            End If
        Next j
        ' Now Lets see if we can fix it:
        wasfixed = False
        For k = i To 1 Step -1
            If intAryEB(k, 2) = intAryEB(i + 1, 2) Then
                ' okay, the row k to i seem to be contained in i+1 and following. Delete k to i ...
                For j = k To lngEBcnt - (i - k + 1) ' ... by copying upwards all later rows...
                    intAryEB(j, 1) = intAryEB(j + (i - k + 1), 1)
                    intAryEB(j, 2) = intAryEB(j + (i - k + 1), 2)
                    intAryEB(j, 3) = intAryEB(j + (i - k + 1), 3)
                    intAryEB(j, 4) = intAryEB(j + (i - k + 1), 4)
                Next j
                lngEBcnt = lngEBcnt - (i - k + 1) ' and correcting the total rowcount
                wasfixed = True
                Debug.Print ("... this should be fixed now::")
                For j = 1 To lngEBcnt
                    Debug.Print (j & ". (" & intAryEB(j, 1) & "): " & intAryEB(j, 2) & " ... " & intAryEB(j, 2) + intAryEB(j, 3))
                Next j
                Exit For
            End If
        Next k
        If Not (wasfixed) Then
            MsgBox ("The input text analysis failed - entering debug mode...")
            Debug.Assert False
        End If
    End If
    i = i + 1
    Wend
    'Debug.Print ("lngebcnt=" & lngebcnt) ' lngebcnt now has its final value
    ' Calculate how many bits the message has in total?
    '----From https://github.com/JonasHeidelberg/barcode-vba-macro-only --- End ---
    
    
    ' 全体のデータ長を初期化
    c = 0
    For lngI = 1 To lngEBcnt
        Select Case intAryEB(lngI, 1)
            Case 1:
                ' Numericモードの場合
                intAryEB(lngI, 4) = Int(intAryEB(lngI, 3) / 3) * 10 + (intAryEB(lngI, 3) Mod 3) * 3 + IIf((intAryEB(lngI, 3) Mod 3) > 0, 1, 0)
            Case 2:
                ' Alphanumericモードの場合
                intAryEB(lngI, 4) = Int(intAryEB(lngI, 3) / 2) * 11 + (intAryEB(lngI, 3) Mod 2) * 6
            Case 3:
                ' Byteモードの場合
                 intAryEB(lngI, 4) = intAryEB(lngI, 3) * 8
        End Select
        ' 各ブロックサイズを加算して合計サイズを計算
        c = c + intAryEB(lngI, 4)
    Next lngI
    
    ' QRコードのパラメータを設定し、エラーレベルやサイズを確定
    
    ' 入力データとエラー訂正レベルを基にQRコードパラメータを設定
    '  UTF-8 is default not need ECI value - zxing cannot recognize
    '  Call qr_params(i * 8 + utf8,strMode,intAryQRParam)
    Call qr_params(c, lngEcl, intAryQRParam, intAryEcx_Poc)
    If intAryQRParam(1) <= 0 Then
        ' データがQRコードの許容量を超える場合のエラーメッセージ
        strErrorMessage = "Too long"
        Exit Function
    End If
    ' QRコードのサイズ情報を取得
    siz = intAryQRParam(2)
    Debug.Print ( _
        "ver:" & intAryQRParam(1) & strMode & " size " & siz & " ecc:" & intAryQRParam(3) _
        & "x" & intAryQRParam(4) & " d:" & (intAryQRParam(5) - intAryQRParam(3) * intAryQRParam(4)) _
        )
  
    ' エンコーディングされたデータのバイト配列を再構築
    ' 必要なサイズに応じてバイト配列を再定義
    ReDim bytAryEncoded1(intAryQRParam(5) + 2)
    ' mode indicator (1=num,2=AlNum,4=Byte,8=kanji,ECI=7)
    '      mode: Byte Alhanum  Numeric  Kanji
    ' ver 1..9 :  8      9       11       8
    '   10..26 : 16     11       12      10
    '   27..40 : 16     13       14      12

    ' UTF-8 is default not need ECI value - zxing cannot recognize
    '  if utf8 > 0 Then
    '    k = &H700 + 26 ' UTF-8=26 ; Win1250 = 21; 8859-2 = 4 viz http://strokescribe.com/en/ECI.html
    '    subBb_PutBits(bytAryEncoded1,intEncix1,k,12)
    '  End If
  
    ' データブロックのタイプとサイズに基づいてエンコード
    ' エンコードされたデータのインデックス初期化
    intEncix1 = 0
    For lngI = 1 To lngEBcnt
        ' 各データブロックをタイプに応じてエンコード
        ' QRコードバージョンに応じたビット数を設定
        Select Case intAryEB(lngI, 1)
            Case 1:
                ' 数字モード
                c = IIf(intAryQRParam(1) < 10, 10, IIf(intAryQRParam(1) < 27, 12, 14))
                ' 必要なビット数でエンコード
                lngK = 2 ^ c + intAryEB(lngI, 3)
            Case 2:
                ' 英数字モード
                c = IIf(intAryQRParam(1) < 10, 9, IIf(intAryQRParam(1) < 27, 11, 13))
                ' 必要なビット数でエンコード
                lngK = 2 * (2 ^ c) + intAryEB(lngI, 3)
            Case 3:
                ' バイトモード
                c = IIf(intAryQRParam(1) < 10, 8, 16)
                ' 必要なビット数でエンコード
                lngK = 4 * (2 ^ c) + intAryEB(lngI, 3)
        End Select
        ' エンコード結果をバイト配列に書き込み
        Call subBb_PutBits(bytAryEncoded1, intEncix1, lngK, c + 4)
        
        ' データブロック内の各文字をエンコード
        ' 現在のデータブロック内の位置初期化
        j = 0
         ' データブロックの開始位置
        lngM = intAryEB(lngI, 2)
        ' 一時的な結果を保持する変数
        lngR = 0
        While j < intAryEB(lngI, 3)
            ' 各文字のUnicodeコードポイントを取得
            lngK = AscL(Mid(strPtext, lngM, 1))
            '全角文字の、「AscW」でマイナス値が返って来た場合の処理
            If lngK < 0 Then lngK = lngK + 65536
            ' 次の文字へ移動
            lngM = lngM + 1
            ' モードに応じたエンコード処理
            If intAryEB(lngI, 1) = 1 Then
                ' 数字モード
                lngR = (lngR * 10) + ((lngK - &H30) Mod 10)
                If (j Mod 3) = 2 Then
                    ' 3文字ごとにエンコード
                    'QRコード用のビット配列を設定するサブルーチンで処理をする。
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, lngR, 10)
                    lngR = 0
                End If
                j = j + 1
            ElseIf intAryEB(lngI, 1) = 2 Then
                ' 英数字モード
                lngR = (lngR * 45) + ((InStr(qralnum, Chr(lngK)) - 1) Mod 45)
                If (j Mod 2) = 1 Then
                    ' 2文字ごとにエンコード
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, lngR, 11)
                    lngR = 0
                End If
                j = j + 1
            Else
                ' バイトモード
                ' 各文字のバイト数に応じたエンコード処理
                If lngK > &H1FFFFF Then ' FFFF - 1FFFFFFF
                    ' 4バイト文字の場合
                    ch = &HF0 + Int(lngK / &H40000) Mod 8
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    ch = 128 + Int(lngK / &H1000) Mod 64
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    ch = 128 + Int(lngK / 64) Mod 64
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    ch = 128 + lngK Mod 64
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    j = j + 4
                ElseIf lngK > &H7FF Then ' 7FF-FFFF 3 bytes
                    ' 3バイト文字の場合
                    ch = &HE0 + Int(lngK / &H1000) Mod 16
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    ch = 128 + Int(lngK / 64) Mod 64
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    ch = 128 + lngK Mod 64
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    j = j + 3
                ElseIf lngK > &H7F Then
                    ' 2 bytes
                    ' 2バイト文字の場合
                    ch = &HC0 + Int(lngK / 64) Mod 32
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    ch = 128 + lngK Mod 64
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    j = j + 2
                Else
                    ' 1バイト文字の場合
                    ch = lngK Mod 256
                    Call subBb_PutBits(bytAryEncoded1, intEncix1, ch, 8)
                    j = j + 1
                End If
            End If
        Wend
        
        ' 最後のデータを適切に書き込む
        Select Case intAryEB(lngI, 1)
            Case 1:
                If (j Mod 3) = 1 Then
                  Call subBb_PutBits(bytAryEncoded1, intEncix1, lngR, 4)
                ElseIf (j Mod 3) = 2 Then
                  Call subBb_PutBits(bytAryEncoded1, intEncix1, lngR, 7)
                End If
            Case 2:
                If (j Mod 2) = 1 Then Call subBb_PutBits(bytAryEncoded1, intEncix1, lngR, 6)
        End Select
        
        'MsgBox "blk[" & lngI & "] t:" & intAryEB(i,1) & "from " _
        & intAryEB(i,2) & " to " & intAryEB(i,3) + intAryEB(i,2) & " bits=" & intEncix1
    
    Next lngI
  
    ' エンコード終了のシグナルを追加
     ' エンコード終了の指示
    Call subBb_PutBits(bytAryEncoded1, intEncix1, 0, 4) ' end of chain
    ' バイト単位への切り上げ処理
    If (intEncix1 Mod 8) <> 0 Then  ' round to byte
      Call subBb_PutBits(bytAryEncoded1, intEncix1, 0, 8 - (intEncix1 Mod 8))
    End If
    
    ' 必要なエンコードバイト数を計算し、エラー処理を実施
    ' padding
    lngI = (intAryQRParam(5) - intAryQRParam(3) * intAryQRParam(4)) * 8
    If intEncix1 > lngI Then
        ' エンコードのデータ長が許容量を超えた場合のエラー
        strErrorMessage = "Encode length error"
        Exit Function
    End If
  
     'パディングデータ（0xEC, 0x11）をループで追加
    ' padding 0xEC,0x11,0xEC,0x11...
    Do While intEncix1 < lngI
      Call subBb_PutBits(bytAryEncoded1, intEncix1, &HEC11, 16)
    Loop
    
    ' エラー訂正コード（ECC）を生成し、エンコードデータに追加
    ' doplnime ECC
    ' ECCデータの長さを計算
    lngI = intAryQRParam(3) * intAryQRParam(4) 'ppoly, pmemptr , psize , plen , pblocks
    ' Reed-Solomon ECC生成処理
    Call qr_rs(&H11D, bytAryEncoded1, intAryQRParam(5) - lngI, lngI, intAryQRParam(4))

    'Call arr2hexstr(bytAryEncoded1)
    intEncix1 = intAryQRParam(5)
  
    ' QRコードのマトリクス配列を初期化
    ' Pole pro vystup
    ReDim bytAryQR(0)
    ' QRコードのマトリクス領域を確保
    ReDim bytAryQR(1, intAryQRParam(2) * 24& + 24&) ' 24 bytes per row
    bytAryQR(0, 0) = 0
    ch = 0
    ' QRコード同期パターンの追加
    Call subBb_PutBits(bytAryQrsync1, ch, Array(&HFE, &H82, &HBA, &HBA, &HBA, &H82, &HFE, 0), 64)
    ' 左上の同期パターン
    ' sync UL
    Call subQRMask(bytAryQR, bytAryQrsync1, 8, 0, 0)
    
    ' フォーマット情報領域（上左）
    ' fmtinfo UL under - bity 14..9 SYNC 8
    Call subQRMask(bytAryQR, 0, 8, 8, 0)
    
    ' 右上の同期パターン
    ' sync UR ( o bit vlevo )
    Call subQRMask(bytAryQR, bytAryQrsync1, 8, 0, siz - 7)
    
    ' フォーマット情報領域（右上）
    Call subQRMask(bytAryQR, 0, 8, 8, siz - 8)   ' fmtinfo UR - bity 7..0
    Call subQRMask(bytAryQR, bytAryQrsync1, 8, siz - 7, 0) ' sync DL (zasahuje i do quiet zony)
    Call subQRMask(bytAryQR, 0, 8, siz - 8, 0)   ' blank nad DL
    ' QRコードの同期ラインを配置する処理
    For lngI = 0 To 6
      blnX = fncQRBit(bytAryQR, -1, lngI, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7
      blnX = fncQRBit(bytAryQR, -1, lngI, siz - 8, 0) ' svisly blank pred UR
      blnX = fncQRBit(bytAryQR, -1, siz - 1 - lngI, 8, 0) ' svisle fmtinfo DL - bity 14..8
    Next
    
    blnX = fncQRBit(bytAryQR, -1, 7, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7
    blnX = fncQRBit(bytAryQR, -1, 7, siz - 8, 0) ' svisly blank pred UR
    blnX = fncQRBit(bytAryQR, -1, 8, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7
    blnX = fncQRBit(bytAryQR, -1, siz - 8, 8, 1) ' black dot DL
    If intAryQRParam(13) <> 0 Or intAryQRParam(14) <> 0 Then ' versioninfo
    ' UR ver 0 1 2;3 4 5;...;15 16 17
    ' LL ver 0 3 6 9 12 15;1 4 7 10 13 16; 2 5 8 11 14 17
      lngK = 65536 * intAryQRParam(13) + 256& * intAryQRParam(14) + 1& * intAryQRParam(15)
      c = 0: lngR = 0
      For lngI = 0 To 17
        ch = lngK Mod 2
        blnX = fncQRBit(bytAryQR, -1, lngR, siz - 11 + c, ch) ' UR ver
        blnX = fncQRBit(bytAryQR, -1, siz - 11 + c, lngR, ch) ' DL ver
        c = c + 1
        If c > 2 Then c = 0: lngR = lngR + 1
        lngK = Int(lngK / 2&)
      Next
    End If
    
    ' QRコードの同期ラインを配置する処理
    c = 1
    For lngI = 8 To siz - 9 ' sync lines
        ' 垂直方向のライン
        blnX = fncQRBit(bytAryQR, -1, lngI, 6, c) ' vertical on column 6
        ' 水平方向のライン
        blnX = fncQRBit(bytAryQR, -1, 6, lngI, c) ' horizontal on row 6
        c = (c + 1) Mod 2
    Next
  
    ' other syncs
    ch = 0
    Call subBb_PutBits(bytAryQrsync2, ch, Array(&H1F, &H11, &H15, &H11, &H1F), 40)
    ch = 6
    Do While ch > 0 And intAryQRParam(6 + ch) = 0
      ch = ch - 1
    Loop
    If ch > 0 Then
      For c = 0 To ch
        For lngR = 0 To ch
          ' corners
          If (c <> 0 Or lngR <> 0) And _
             (c <> ch Or lngR <> 0) And _
             (c <> 0 Or lngR <> ch) Then
            Call subQRMask(bytAryQR, bytAryQrsync2, 5, intAryQRParam(lngR + 6) - 2, intAryQRParam(c + 6) - 2)
          End If
        Next lngR
      Next c
    End If
  
    ' QRコードのエンコードマトリクスを生成
    ' qr_fill(parr as Variant, psiz%, pb as Variant, pblocks%, pdlen%, ptlen%)
    ' vyplni pole parr (psiz blnX 24 bytes) z pole pb pdlen = pocet dbytes, pblocks = bloku, ptlen celkem
     Call qr_fill(bytAryQR, siz, bytAryEncoded1, intAryQRParam(4), intAryQRParam(5) - intAryQRParam(3) * intAryQRParam(4), intAryQRParam(5))
     
    ' 適切なマスクパターンを選択
    lngMask = 8 ' auto
    lngI = InStr(strP_Options, "mask=")
    If lngI > 0 Then lngMask = Val(Mid(strP_Options, lngI + 5, 1))
    If lngMask < 0 Or lngMask > 7 Then
       j = -1
       For lngMask = 0 To 7
         GoSub addmm
         lngI = qr_xormask(bytAryQR, siz, lngMask, False)
       '      MsgBox "score lngMask " & lngMask & " is " & i
         If lngI < j Or j = -1 Then j = lngI: s = lngMask
       Next lngMask
       lngMask = s
       '    MsgBox "best is " & lngMask & " with score " & j
    End If
  
    'フォーマット情報の計算
    GoSub addmm
    lngI = qr_xormask(bytAryQR, siz, lngMask, True)
  
    ' QRコードの出力文字列を生成
    strAsciMatrix = ""
    For lngR = 0 To siz Step 2
      s = 0
      For c = 0 To siz Step 2
        If (c Mod 8) = 0 Then
          ch = bytAryQR(1, s + 24 * lngR)
          If lngR < siz Then lngI = bytAryQR(1, s + 24 * (lngR + 1)) Else lngI = 0
          s = s + 1
        End If
        strAsciMatrix = strAsciMatrix _
           & Chr(97 + (ch Mod 4) + 4 * (lngI Mod 4))
        ch = Int(ch / 4)
        lngI = Int(lngI / 4)
      Next
      strAsciMatrix = strAsciMatrix & vbNewLine
    Next lngR
    ReDim bytAryQR(0)
    
    ' QRコードのエンコード結果を返す
    fncQR_Gen = strAsciMatrix
    Exit Function

addmm:
    ' エラー訂正レベルとマスクパターンを組み合わせた値を計算
    ' BCH符号を計算してフォーマット情報の準備を行う
    lngK = lngEcl * 8 + lngMask
    ' BCH符号生成
    ' poly: 101 0011 0111
    Call qr_bch_calc(lngK, &H537)
    'MsgBox "mask :" & hex(k,3) & " " & hex(k xor &H5412,3)
    
    ' フォーマット情報の固定XOR値を適用
    lngK = lngK Xor &H5412 ' micro xor &H4445
    ' 初期行インデックス
    lngR = 0
    ' 初期列インデックス
    c = siz - 1
     ' フォーマット情報をQRコードのマトリクスに設定
    For lngI = 0 To 14
        ' BCH符号から次のビット値を取得
        ch = lngK Mod 2
        ' BCH符号を1ビットずつシフト
        lngK = Int(lngK / 2)
        
        ' 縦方向のフォーマット情報（左上）
        ' svisle fmtinfo UL - bity 0..5 SYNC 6,7 .... 8..14 dole
        blnX = fncQRBit(bytAryQR, -1, lngR, 8, ch)
        
        ' 横方向のフォーマット情報（右上）
        ' vodorovne odzadu 0..7 ............ 8,SYNC,9..14
        blnX = fncQRBit(bytAryQR, -1, 8, c, ch)
        ' 列を左に進める
        c = c - 1
        ' 行を下に進める
        lngR = lngR + 1
        ' フォーマット情報の位置調整
        If lngI = 7 Then
            ' 右上の同期パターンを避ける
            c = 7
            ' 下部の同期パターン領域に移動
            lngR = siz - 7
        End If
        ' 同期パターン領域をスキップ（横方向）
        If lngI = 5 Then lngR = lngR + 1 ' preskoc sync vodorvny
        ' 同期パターン領域をスキップ（縦方向）
        If lngI = 8 Then c = c - 1 ' preskoc sync svisly
    Next
    
    Return

' fncQR_Gen
End Function


'多分LibreOffice用のバーコード描画サブルーチン
Sub bc_2D( _
    ShIx As Integer _
    , xAddr As String _
    , xBC As String _
    )
    
    Dim xPage As Object
    Dim xShape As Object
    Dim xDoc As Object
    Dim xView As Object
    Dim xProv As Object
    Dim xSheet As Object
    Dim xRange As Object
    Dim xCell As Object
    
    
    ' 図形の位置を設定する変数 LibreOffice用かもしれない
    Dim xPos As New com.sun.star.awt.Point
    ' 既存の図形の位置を保持する変数
    Dim xPosOld As New com.sun.star.awt.Point
    ' 図形のサイズを設定する変数
    Dim xSize As New com.sun.star.awt.Size
    ' 既存の図形のサイズを保持する変数
    Dim xSizeOld As New com.sun.star.awt.Size
    ' グループ図形を操作するための変数
    Dim xGrp As Object
    ' 図形の塗りつぶしスタイルを指定する値
    Dim xSolid As Long
    Dim x&, y&, n%, w%, s$, p$, m&, dm&, a&, b%
  
    ' ドキュメントやワークシートの情報を取得
    xDoc = ThisComponent
    On Error GoTo e2derr
    xView = ThisComponent.getCurrentController()
    xSheet = xDoc.Sheets.getByIndex(ShIx - 1)
    ' 対象セルの範囲を取得
    xCell = xSheet.getCellRangeByName(xAddr)
    ' ワークシートの描画ページを取得
    xPage = xSheet.getDrawPage()
    On Error GoTo 0
    
    ' 1ブロックのサイズを設定
    m = 60 ' block size
    xSolid = 1 ' com.sun.star.drawing.FillStyle.SOLID = 1
    xPosOld.x = xCell.Position.x
    xPosOld.y = xCell.Position.y
    xSizeOld.Width = 0
    xSizeOld.Height = 0
    
    ' QRコード用のグループ名を生成
    s = "BC" & xAddr & "#GR"
  
    '既存のQRコード図形を削除して初期化
    If xPage.hasElements() Then
        For n = (xPage.getCount() - 1) To 0 Step -1
            xShape = xPage.getByIndex(n)
            If xShape.Name = s Then
                xPosOld.x = xShape.Position.x
                xPosOld.y = xShape.Position.y
                xSizeOld.Width = xShape.Size.Width
                xSizeOld.Height = xShape.Size.Height
                ' 既存のQRコード図形を削除
                xPage.Remove (xShape)
            End If
        Next n
    End If
    
    ' QRコードの文字列を解析してブロックサイズや位置を計算
    x = 0
    y = 0
    a = 0
    ' 1ブロックの幅（2倍）
    dm = m * 2&
    n = 1
    ' QRコードデータ文字列をトリム
    p = Trim(xBC)
    b = Len(p)
    'bbccddeeffgghhiijjkkllmmnnoopp
    '^  ^^^. I .^I^ .^. I^I..I..III
    Do While n <= b
        ' データ文字列から文字コードを取得
        w = AscL(Mid(p, n, 1)) Mod 256
        If w >= 97 And w <= 112 Then
            ' ブロックの幅を加算
            a = a + dm
        End If
        If w = 10 Or n = b Then
            ' 行を進める
            y = y + dm
            ' 最大幅を更新
            If a > x Then x = a
            a = 0
        End If
        n = n + 1
    Loop
    Debug.Print ("bc_2D" & " " & x & " " & y)
    
    ' QRコードが生成できない場合は終了
    If x = 0 Or y = 0 Then Exit Sub
    
    ' グループ図形を作成して、背景を設定
    xGrp = xDoc.createInstance("com.sun.star.drawing.GroupShape")
    xGrp.Name = s
    xPage.Add (xGrp)
    xShape = xDoc.createInstance("com.sun.star.drawing.RectangleShape")
    xShape.LineWidth = 0
    xShape.LineStyle = com.sun.star.Drawing.LineStyle.NONE
    xShape.FillStyle = xSolid
    xShape.FillColor = RGB(255, 255, 255)
    xPos.x = 0
    xPos.y = 0
    xShape.Position = xPos
    xSize.Width = x
    xSize.Height = y
    xShape.Size = xSize
    ' 背景をグループに追加
    xGrp.Add (xShape)
    
    ' QRコードの各ブロックを描画
    x = 0
    y = 0
    a = 1
    For n = 1 To b
        w = AscL(Mid(p, n, 1)) Mod 256
        If w = 10 Then
            ' 行を進める
            y = y + dm
            x = 0
        ElseIf (w >= 97 And w <= 112) Then
            w = w - 97
            xSize.Height = m: xSize.Width = m: xPos.x = x: xPos.y = y
            Select Case w
                Case 1
                    ' 黒ブロックを描画
                    GoSub crrect
                Case 2: xPos.x = x + m: GoSub crrect
                Case 3: xSize.Width = dm: GoSub crrect
                Case 4: xPos.y = y + m: GoSub crrect
                Case 5: xSize.Height = dm: GoSub crrect
                Case 6: xPos.x = x + m: GoSub crrect: xPos.x = x: xPos.y = y + m: GoSub crrect
                Case 7: xSize.Width = dm: GoSub crrect: xSize.Width = m: xPos.y = y + m: GoSub crrect
                Case 8: xPos.y = y + m: xPos.x = x + m: GoSub crrect
                Case 9: GoSub crrect: xPos.y = y + m: xPos.x = x + m: GoSub crrect
                Case 10: xPos.x = x + m: xSize.Height = dm: GoSub crrect
                Case 11: GoSub crrect: xPos.x = x + m: xSize.Height = dm: GoSub crrect
                Case 12: xPos.y = y + m: xSize.Width = dm: GoSub crrect
                Case 13: GoSub crrect: xPos.y = y + m: xSize.Width = dm: GoSub crrect
                Case 14: xPos.x = x + m: GoSub crrect: xPos.x = x: xPos.y = y + m: xSize.Width = dm: GoSub crrect
                Case 15: xSize.Width = dm: xSize.Height = dm: GoSub crrect
            End Select
            ' 次の列に進める
            x = x + dm
        End If
    Next n
    
    ' グループ図形を表示し、位置やサイズを設定
    xGrp.Visible = True
    xGrp.Position = xPosOld
    If xSizeOld.Width > 0 Then xGrp.Size = xSizeOld
    
    ' 変数を解放
    Erase xPos
    Erase xSize
    Erase xPosOld
    Erase xSizeOld
    Exit Sub
    
crrect:
     ' 黒ブロックを描画
    xShape = xDoc.createInstance("com.sun.star.drawing.RectangleShape")
    xShape.LineWidth = 0
    xShape.LineStyle = com.sun.star.Drawing.LineStyle.NONE
    
    ' 枠線を白に設定
    xShape.LineColor = RGB(255, 255, 255)
    xShape.FillStyle = xSolid
    ' 塗りつぶしを黒に設定
    xShape.FillColor = RGB(0, 0, 0)
    xShape.Position = xPos
    xShape.Size = xSize
    xShape.Name = xAddr & "#BR" & a
    ' グループに追加
    xGrp.Add (xShape)
    a = a + 1
    Return

e2derr:
  On Error GoTo 0
End Sub

Sub bc_1D(ShIx As Integer, xAddr As String, xBC As String)
  Dim xPage As Object
  Dim xShape As Object
  Dim xDoc As Object
  Dim xView As Object
  Dim xProv As Object
  Dim xSheet As Object
  Dim xRange As Object
  Dim xCell As Object
  Dim xPos As New com.sun.star.awt.Point
  Dim xPosOld As New com.sun.star.awt.Point
  Dim xSize As New com.sun.star.awt.Size
  Dim xSizeOld As New com.sun.star.awt.Size
  Dim xGrp As Object
  Dim xSolid As Long
  Dim x&, n%, w%, s$, m&
  
  xDoc = ThisComponent
  On Error GoTo e1derr
  xView = ThisComponent.getCurrentController()
  xSheet = xDoc.Sheets.getByIndex(ShIx - 1)
  xCell = xSheet.getCellRangeByName(xAddr)
  xPage = xSheet.getDrawPage()
  On Error GoTo 0
  m = 60&
  xSolid = 1 ' com.sun.star.drawing.FillStyle.SOLID = 1
  xPosOld.x = xCell.Position.x
  xPosOld.y = xCell.Position.y
  xSizeOld.Width = 0
  xSizeOld.Height = 0
  s = "BC" & xAddr & "#GR"
  If xPage.hasElements() Then
    For n% = (xPage.getCount() - 1) To 0 Step -1
      xShape = xPage.getByIndex(n%)
      If xShape.Name = s Then
        xPosOld.x = xShape.Position.x
        xPosOld.y = xShape.Position.y
        xSizeOld.Width = xShape.Size.Width
        xSizeOld.Height = xShape.Size.Height
        xPage.Remove (xShape)
      End If
    Next n%
  End If
  x = 0
  For n = 1 To Len(xBC)
    w = AscL(Mid(xBC, n, 1)) Mod 256
    If (w >= 48 And w <= 57) Then
      w = (w - 48) Mod 5 + 1
    ElseIf (w >= 65 And w <= 69) Then
      w = w - 64
    Else
      w = 0
    End If
    x = x + m * w
  Next n
  If x = 0 Then Exit Sub
  xGrp = xDoc.createInstance("com.sun.star.drawing.GroupShape")
  xGrp.Name = s
  xPage.Add (xGrp)
  xShape = xDoc.createInstance("com.sun.star.drawing.RectangleShape")
  xShape.LineWidth = 0
  xShape.LineStyle = com.sun.star.Drawing.LineStyle.NONE
  xShape.FillStyle = xSolid
  xShape.FillColor = RGB(255, 255, 255)
  xPos.x = 0
  xPos.y = 0
  xShape.Position = xPos
  xSize.Width = x
  xSize.Height = m * 18
  xShape.Size = xSize
  xGrp.Add (xShape)
  x = 0
  For n = 1 To Len(xBC)
    w = AscL(Mid(xBC, n, 1)) Mod 256
    If (w >= 48 And w <= 57) Then
      xShape = xDoc.createInstance("com.sun.star.drawing.RectangleShape")
      xShape.LineWidth = 0
      xShape.LineStyle = com.sun.star.Drawing.LineStyle.NONE
      If w >= 53 Then xSize.Height = m * 15 Else xSize.Height = m * 17
      w = (w - 48) Mod 5 + 1
      xShape.FillStyle = xSolid
      xShape.FillColor = RGB(0, 0, 0)
      xPos.x = x
      xPos.y = 0
      xSize.Width = m * w
      xShape.Position = xPos
      xShape.Size = xSize
      xShape.Name = xAddr & "#BR" & x
      xGrp.Add (xShape)
    ElseIf (w >= 65 And w <= 69) Then
      w = w - 64
    Else
      w = 0
    End If
    x = x + m * w
  Next n
  xGrp.Visible = True
  xGrp.Position = xPosOld
  If xSizeOld.Width > 0 Then xGrp.Size = xSizeOld
  Erase xPos
  Erase xSize
  Erase xPosOld
  Erase xSizeOld
  Exit Sub
e1derr:
  Exit Sub
End Sub


' RGB値255,255,255は白()
Private Sub subRGBTripleSetTo( _
    ByRef rgbAryTarget() As RGBTRIPLE, _
    ByVal bytRgbRed As Byte, _
    ByVal bytRgbGreen As Byte, _
    ByVal bytRgbBlue As Byte _
    )
    
    Dim intRgbAryTargetX As Integer
    intRgbAryTargetX = 0
    Dim intRgbAryTargetY As Integer
    intRgbAryTargetY = 0
    
    For intRgbAryTargetX = LBound(rgbAryTarget, 1) To UBound(rgbAryTarget, 1)
        For intRgbAryTargetY = LBound(rgbAryTarget, 2) To UBound(rgbAryTarget, 2)
        
            With rgbAryTarget(intRgbAryTargetX, intRgbAryTargetY)
                .rgbRed = bytRgbRed
                .rgbGreen = bytRgbGreen
                .rgbBlue = bytRgbBlue
            End With
            
        Next intRgbAryTargetY
    Next intRgbAryTargetX
    
End Sub

Private Sub subCropRGB( _
    ByRef rgbAryFrom() As RGBTRIPLE, _
    ByRef rgbAryTo() As RGBTRIPLE _
    )
    
    Dim intRGBAryToY As Integer
    Dim intRGBAryToX As Integer
    
    For intRGBAryToY = LBound(rgbAryTo, 2) To UBound(rgbAryTo, 2)
    
        For intRGBAryToX = LBound(rgbAryTo, 1) To UBound(rgbAryTo, 1)
            With rgbAryTo(intRGBAryToY, intRGBAryToX)
                .rgbBlue = rgbAryFrom(intRGBAryToY, intRGBAryToX).rgbBlue
                .rgbGreen = rgbAryFrom(intRGBAryToY, intRGBAryToX).rgbGreen
                .rgbRed = rgbAryFrom(intRGBAryToY, intRGBAryToX).rgbRed
            End With
        Next intRGBAryToX
    
    Next intRGBAryToY

End Sub

'''<summary>
'''QRコード作成のための関数bc_2Dmsで、形状やセル範囲を操作してQRコードを描画
'''</summary>
'''<param name="xBC"></param>
'''<param name="xNam">出力するワークシート名</param>
'''<param name="intOutputMode"></param>
Private Function bc_2Dms( _
    xBC As String _
    , Optional xNam As String = "QR" _
    , Optional intOutputMode As Integer = 0 _
    ) As RGBTRIPLE()
    Dim xShape As Shape, xBkgr As Shape
    Dim xSheet As Worksheet
    Dim xRange As Range, xCell As Range
    Dim xAddr As String
    Dim xPosOldX As Double, xPosOldY As Double
    Dim xSizeOldW As Double, xSizeOldH As Double
    
    '意図: 現在の描画位置の横方向（X座標）の位置を保持します。
    '初心者向け変数名: currentXPos（現在のX座標）または posX（X位置）
    Dim dblCurrentXPos As Double
    
    '意図: 現在の描画位置の縦方向（Y座標）の位置を保持します。
    '初心者向け変数名: currentYPos（現在のY座標）または posY（Y位置）
    Dim dblCurrentYPos As Double
    
    '意図: QRコード内の基本単位（セルやシェイプの最小サイズ）を表します。
    '初心者向け変数名: baseUnitSize（基本単位サイズ）または unitSize（単位サイズ）
    Dim m As Double
    
    '意図: 基本単位の2倍サイズを表し､セルやシェイプの拡大に使用されます｡
    '初心者向け変数名: doubleUnitSize（2倍単位サイズ）または expandedSize（拡張サイズ）
    Dim dm As Double
    
    Dim intCharacterCodeW As Integer
    Dim strShapeName As String
    Dim b%, h%, g%
    'QRコード用文字をこの関数内用に処理したデータ
    Dim strProcessedData As String
    
    '作業用のRGBTRIPLE
    Dim rgbImgDataWork() As RGBTRIPLE
    
    Select Case intOutputMode
        Case 0
            'Shape
        
        Case 1
            'Range
            ' マクロが呼び出されたオブジェクトがセル範囲である場合の処理
            If TypeName(Application.Caller) = "Range" Then
                'Rangeだった
                ' 呼び出し元のセルのワークシートと範囲を取得し、対応するプロパティを設定する
                Set xSheet = Application.Caller.Worksheet
                Set xRange = Application.Caller
                xAddr = xRange.Address
                xPosOldX = xRange.Left
                xPosOldY = xRange.Top
            Else
                'Range以外だった
                'デフォルトのワークシート(1番目)を設定する
                Set xSheet = Worksheets(1)
                'オプション引数xNamが指定されていたかどうかの判定
                If Len(xNam) > 0 Then
                    xAddr = xNam
                Else
                    xAddr = "QR"
                End If
            End If
            
        Case 2
            'BMP
            'QRcode 最大 ver40 177セル×177セルのRGBTRIPLE を確保する
            ReDim rgbImgDataWork(176, 176) As RGBTRIPLE
            'あとで特定部分を黒にするので最初に全てを白色で塗りつぶす
            Call subRGBTripleSetTo(rgbImgDataWork, 255, 255, 255)
            
    End Select
     
    ' 初期化：以前のシェイプ情報をリセットする
    xSizeOldW = 0
    xSizeOldH = 0
    
    ' QRコード用シェイプの名前を生成
    strShapeName = "BC" & xAddr & "#GR"
    
    'QRコードのサイズを計算
    '座標を初期化
    dblCurrentXPos = 0#
    dblCurrentYPos = 0#
     
    ' 各セルやシェイプの基本サイズ
    m = 2.5
    ' 基本単位の2倍を計算
    dm = m * 2#
    
    'QRコードのサイズを計算するのための現在の幅を保持する変数
    Dim dblCurrentWidthA As Double
    dblCurrentWidthA = 0#
    ' xBCの値をトリムして処理用文字列に設定
    strProcessedData = Trim(xBC)
    ' 処理対象文字列の長さを取得
    b = Len(strProcessedData)
    
    ' 文字列内の各文字を処理してシェイプの位置と大きさを計算
    '現在処理している文字の位置
    Dim n As Integer
    '入力文字を先頭から最後まで処理していく
    For n = 1 To b
        '文字列 strProcessedData の中から特定の文字コードを取得し、そのコードを256で割った余りを計算
        intCharacterCodeW = AscL(Mid(strProcessedData, n, 1)) Mod 256
        ' 特定の文字範囲の場合、幅を増加 (97)a ... (112)p
        If (intCharacterCodeW >= 97 And intCharacterCodeW <= 112) Then
            dblCurrentWidthA = dblCurrentWidthA + dm
        ElseIf intCharacterCodeW = 10 Or n = b Then
            '(10)LF 改行か、終端の場合
            If dblCurrentXPos < dblCurrentWidthA Then dblCurrentXPos = dblCurrentWidthA
            dblCurrentYPos = dblCurrentYPos + dm
            dblCurrentWidthA = 0#
        End If
    Next n
    
    Debug.Print ("bc_2Dms()" & " x:" & dblCurrentXPos & " y:" & dblCurrentYPos)
 
    ' QRコードのサイズがゼロの場合は終了
    If dblCurrentXPos <= 0# Then Exit Function
    
    Select Case intOutputMode
        Case 0
            'Shape
            ' 前回のQRコード用シェイプを削除
            On Error Resume Next
            Set xShape = xSheet.Shapes(strShapeName)
            On Error GoTo 0
            If Not (xShape Is Nothing) Then
                xPosOldX = xShape.Left
                xPosOldY = xShape.Top
                xSizeOldW = xShape.Width
                xSizeOldH = xShape.Height
                xShape.Delete
            End If
            
            ' 背景シェイプの削除と新しい背景の生成
            On Error Resume Next
            xSheet.Shapes("BC" & xAddr & "#BK").Delete
            On Error GoTo 0
            
            ' 背景の追加
            Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, dblCurrentXPos, dblCurrentYPos)
            ' 線を非表示
            xBkgr.Line.Visible = msoFalse
            xBkgr.Line.Weight = 0#
            xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255)
            ' 白い背景色を設定
            xBkgr.Fill.Solid
            xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255)
            ' 背景シェイプの名前を設定
            xBkgr.Name = "BC" & xAddr & "#BK"
                   
        Case Else
    
    End Select
    
    
    ' QRコード用のセルやシェイプを描画する準備
    Set xShape = Nothing
    dblCurrentXPos = 0#
    dblCurrentYPos = 0#
    g = 0
    
    Dim intRGBImgDataWorkX As Integer
    Dim intRGBImgDataWorkY As Integer
    Dim intRGBImgDataWorkMaxX As Integer
    Dim intRGBImgDataWorkMaxY As Integer
    
    For n = 1 To b
        ' 各文字を再解析
        'キャラクターコードを得る
        intCharacterCodeW = AscL(Mid(strProcessedData, n, 1)) Mod 256
        '1 (SOH): Start of Heading (ヘッダーの開始)
        '
        '2 (STX): Start of Text (テキストの開始)
        '
        '3 (ETX): End of Text (テキストの終了)
        '
        '4 (EOT): End of Transmission (送信の終了)
        '
        '5 (ENQ): Enquiry (問い合わせ)
        '
        '6 (ACK): Acknowledge (確認応答)
        '
        '7 (BEL): Bell (ベル音、警告音)
        '
        '8 (BS): Backspace (バックスペース)
        '
        '9 (TAB): Horizontal Tab (水平タブ)
        '
        '10 (LF): Line Feed (改行)
        '
        '11 (VT): Vertical Tab (垂直タブ)
        '
        '12 (FF): Form Feed (改ページ)
        '
        '13 (CR): Carriage Return (復帰)
        '
        '14 (SO): Shift Out (シフトアウト)
        '
        '15 (SI): Shift In (シフトイン)
        
        If intCharacterCodeW = 10 Then
            ' 改行の場合、次の行へ移動
            dblCurrentYPos = dblCurrentYPos + dm
            dblCurrentXPos = 0#
        ElseIf (intCharacterCodeW >= 97 And intCharacterCodeW <= 112) Then
            intCharacterCodeW = intCharacterCodeW - 97
            
            'expression. AddShape( _Type_ , _Left_ , _Top_ , _Width_ , _Height_ )
       
            '    Select Case w
            '    Case 1:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_m:" & m
            '    Case 2:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_m:" & m
            '    Case 3:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_dm:" & dm & "_m:" & m
            '    Case 4:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_m:" & m & "_m:" & m
            '    Case 5:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_dm:" & dm
            '    Case 6:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_m:" & m
            '                Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_m:" & m & "_m:" & m
            '    Case 7:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_dm:" & dm & "_m:" & m
            '                Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_m:" & m & "_m:" & m
            '    Case 8:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_m:" & m & "_m:" & m
            '    Case 9:     Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_m:" & m
            '                Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_m:" & m & "_m:" & m
            '    Case 10:    Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_dm:" & dm
            '    Case 11:    Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_dm:" & dm & "_m:" & m
            '                Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_m:" & m & "_m:" & m
            '    Case 12:    Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_dm:" & dm & "_m:" & m
            '    Case 13:    Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_m:" & m
            '                Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_dm:" & dm & "_m:" & m
            '    Case 14:    Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos+m:" & dblCurrentXPos + m & "_dblCurrentYPos:" & dblCurrentYPos & "_m:" & m & "_m:" & m
            '                Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos+m:" & dblCurrentYPos + m & "_dm:" & dm & "_m:" & m
            '    Case 15:    Debug.Print "intCharacterCodeW:" & intCharacterCodeW & "_dblCurrentXPos:" & dblCurrentXPos & "_dblCurrentYPos:" & dblCurrentYPos & "_dm:" & dm & "_dm:" & dm
            '    End Select

            Select Case intOutputMode
            
                Case 0
                    'Shapeで描画する場合
                    ' 各範囲や条件に応じたセルやシェイプを生成
                    With xSheet.Shapes
                    
                        Select Case intCharacterCodeW
                          Case 1: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, m, m): GoSub fmtxshape
                          Case 2: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos, m, m): GoSub fmtxshape
                          Case 3: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, dm, m): GoSub fmtxshape
                          Case 4: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos + m, m, m): GoSub fmtxshape
                          Case 5: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, m, dm): GoSub fmtxshape
                          Case 6: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos, m, m): GoSub fmtxshape
                                  Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos + m, m, m): GoSub fmtxshape
                          Case 7: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, dm, m): GoSub fmtxshape
                                  Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos + m, m, m): GoSub fmtxshape
                          Case 8: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos + m, m, m): GoSub fmtxshape
                          Case 9: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, m, m): GoSub fmtxshape
                                  Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos + m, m, m): GoSub fmtxshape
                          Case 10: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos, m, dm): GoSub fmtxshape
                          Case 11: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, dm, m): GoSub fmtxshape
                                   Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos + m, m, m): GoSub fmtxshape
                          Case 12: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos + m, dm, m): GoSub fmtxshape
                          Case 13: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, m, m): GoSub fmtxshape
                                   Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos + m, dm, m): GoSub fmtxshape
                          Case 14: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos + m, dblCurrentYPos, m, m): GoSub fmtxshape
                                   Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos + m, dm, m): GoSub fmtxshape
                          Case 15: Set xShape = .AddShape(msoShapeRectangle, dblCurrentXPos, dblCurrentYPos, dm, dm): GoSub fmtxshape
                        End Select
                    End With
                    
                Case 1
                    ' ワークシートに描画する場合
                    Select Case intCharacterCodeW

                        Case 1
                            'QRコードシート上で指定範囲を描画します
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, m, m)
                        Case 2
                            ' セルの右に描画
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos, m, m)
                        Case 3
                            ' 横長のセルを描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, dm, m)
                        Case 4
                            ' セルの下に描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos + m, m, m)
                        Case 5
                            ' 縦長のセルを描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, m, dm)
                        Case 6
                            ' 上下に連続で描画
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos, m, m)
                            Call subDraw(dblCurrentXPos, dblCurrentYPos + m, m, m)
                        Case 7
                            ' 横長のセルを描画し、下も描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, dm, m)
                            Call subDraw(dblCurrentXPos, dblCurrentYPos + m, m, m)
                        Case 8
                            ' 右下に小さなセルを描画
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos + m, m, m)
                        Case 9
                            ' 右下と左上にセルを描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, m, m)
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos + m, m, m)
                        Case 10
                            ' 横長セルを右に描画
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos, m, dm)
                        Case 11
                            ' 横長セルを描画し右下にも描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, dm, m)
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos + m, m, m)
                        Case 12
                            ' 横長セルを下に描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos + m, dm, m)
                        Case 13
                            ' 縦長セルを左に描画
                            Call subDraw(dblCurrentXPos, dblCurrentYPos, m, m)
                            Call subDraw(dblCurrentXPos, dblCurrentYPos + m, dm, m)
                        Case 14
                            ' セル右と下に連続描画
                            Call subDraw(dblCurrentXPos + m, dblCurrentYPos, m, m)
                            Call subDraw(dblCurrentXPos, dblCurrentYPos + m, dm, m)
                        Case 15
                             ' セル全体を塗りつぶす
                             Call subDraw(dblCurrentXPos, dblCurrentYPos, dm, dm)
                    End Select
                    

                Case Else
                    '配列に直接書き込んで、画像ファイルにして、対象セルにShapeで貼り付ける場合
                    '　rgbImgDataWork() As RGBTRIPLE
                    Select Case intCharacterCodeW

                        Case 1
                            'QRコードシート上で指定範囲を描画します
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 2
                            ' セルの右に描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 3
                            ' 横長のセルを描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, dm, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 4
                            ' セルの下に描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos + m, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 5
                            ' 縦長のセルを描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, m, dm, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 6
                            ' 上下に連続で描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos + m, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 7
                            ' 横長のセルを描画し、下も描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, dm, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos + m, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 8
                            ' 右下に小さなセルを描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos + m, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 9
                            ' 右下と左上にセルを描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos + m, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 10
                            ' 横長セルを右に描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos, m, dm, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 11
                            ' 横長セルを描画し右下にも描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, dm, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos + m, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 12
                            ' 横長セルを下に描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos + m, dm, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 13
                            ' 縦長セルを左に描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos + m, dm, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 14
                            ' セル右と下に連続描画
                            Call subDrawToRGBTRIPLE(dblCurrentXPos + m, dblCurrentYPos, m, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos + m, dm, m, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                        Case 15
                            ' セル全体を塗りつぶす
                            Call subDrawToRGBTRIPLE(dblCurrentXPos, dblCurrentYPos, dm, dm, rgbImgDataWork, intRGBImgDataWorkX, intRGBImgDataWorkY)
                    End Select
                    
            End Select

            dblCurrentXPos = dblCurrentXPos + dm
        End If
        
        '後で配列分だけ切り出せるように最大値を覚えておく
        If (intRGBImgDataWorkMaxX < intRGBImgDataWorkX) Then
            intRGBImgDataWorkMaxX = intRGBImgDataWorkX
        End If
        If (intRGBImgDataWorkMaxY < intRGBImgDataWorkY) Then
            intRGBImgDataWorkMaxY = intRGBImgDataWorkY
        End If
               
    Next n
 
    '出力用のRGBTRIPLE
    Dim rgbImgDataOutput() As RGBTRIPLE
    
    Select Case intOutputMode
    
        Case 0
            'Shapeで描画する場合
            On Error Resume Next
            Set xShape = xSheet.Shapes(strShapeName)
            On Error GoTo 0
            If Not (xShape Is Nothing) Then
                xShape.Left = xPosOldX
                xShape.Top = xPosOldY
                If xSizeOldW > 0 Then
                    xShape.Width = xSizeOldW
                    xShape.Height = xSizeOldH
                End If
            Else
                If Not (xBkgr Is Nothing) Then xBkgr.Delete
            End If
            
        Case 2
            Debug.Print ("intRGBImgDataWorkMaxY:" & intRGBImgDataWorkMaxY & " intRGBImgDataWorkMaxX:" & intRGBImgDataWorkMaxX)
            'BMP
            '出力できたQR画像範囲を確保する。
            ReDim rgbImgDataOutput(intRGBImgDataWorkMaxY, intRGBImgDataWorkMaxX) As RGBTRIPLE
            
            '作業用のRGBから出力用のRGBに切り出しを行う
            Call subCropRGB(rgbImgDataWork, rgbImgDataOutput)
    End Select
    
    bc_2Dms = rgbImgDataOutput()
    
    Exit Function
    

fmtxshape:
    xShape.Line.Visible = msoFalse
    xShape.Line.Weight = 0#
    xShape.Fill.Solid
    xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)
    g = g + 1
    xShape.Name = "BC" & xAddr & "#BR" & g
    If g = 1 Then
      xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = strShapeName
    Else
      xSheet.Shapes.Range(Array(strShapeName, xShape.Name)).Group.Name = strShapeName
    End If
    Return
End Function


''' <summary>
''' QRコードシート上で指定範囲を描画します
''' </summary>
''' <param name="dblA">描画開始位置のX座標</param>
''' <param name="dblB">描画開始位置のY座標</param>
''' <param name="dblC">描画幅</param>
''' <param name="dblD">描画高さ</param>
''' <remarks>セルの値に1を設定して描画します</remarks>
Sub subDraw( _
    dblA As Double, _
    dblB As Double, _
    dblC As Double, _
    dblD As Double _
    )
    Dim intXc As Integer ' X座標を表す変数
    Dim intYr As Integer ' Y座標を表す変数
    Dim intWidth As Integer ' 描画幅を表す変数
    Dim intHeight As Integer ' 描画高さを表す変数

    ' X座標とY座標を計算
    intXc = CInt((dblA / 2.5) + 1)
    intYr = CInt((dblB / 2.5) + 1)

    ' 幅と高さを計算
    intWidth = CInt((dblC / 2.5) + 0)
    intHeight = CInt((dblD / 2.5) + 0)

    ' セルに値を設定して描画
    Sheets("QR").Cells(intYr, intXc).Value = 1

    ' 幅方向の描画
    If intWidth > 1 Then
        Sheets("QR").Cells(intYr, intXc + 1).Value = 1
    End If

    ' 高さ方向の描画
    If intHeight > 1 Then
        Sheets("QR").Cells(intYr + 1, intXc).Value = 1
    End If

    ' 幅と高さの両方が2以上の場合
    If intWidth > 1 And intHeight > 1 Then
        Sheets("QR").Cells(intYr + 1, intXc + 1).Value = 1
    End If
End Sub

''' <summary>
''' RGBTRIPLEに書き込みます
''' </summary>
''' <param name="dblA">描画開始位置のX座標</param>
''' <param name="dblB">描画開始位置のY座標</param>
''' <param name="dblC">描画幅</param>
''' <param name="dblD">描画高さ</param>
'''    Dim  ' X座標を表す変数
'''    Dim  ' X座標を表す変数
''' <remarks>セルの値に1を設定して描画します</remarks>
Private Sub subDrawToRGBTRIPLE( _
    dblA As Double, _
    dblB As Double, _
    dblC As Double, _
    dblD As Double, _
    ByRef rgbImgDataWork() As RGBTRIPLE, _
    ByRef intRGBImgDataWorkX As Integer, _
    ByRef intRGBImgDataWorkY As Integer _
    )
    Dim intWidth As Integer ' 描画幅を表す変数
    Dim intHeight As Integer ' 描画高さを表す変数

    Dim intXc As Integer
    Dim intYr As Integer

    ' X座標とY座標を計算
    intXc = CInt((dblA / 2.5) + 1)
    intYr = CInt((dblB / 2.5) + 1)

    ' 幅と高さを計算
    intWidth = CInt((dblC / 2.5) + 0)
    intHeight = CInt((dblD / 2.5) + 0)

    'RGBTRIPLE配列要素は0開始なので1を引く
    'Dim intRGBImgDataWorkX As Integer
    intRGBImgDataWorkX = intXc - 1
    'Dim intRGBImgDataWorkY As Integer
    intRGBImgDataWorkY = intYr - 1
    
    ' セルに値を設定して描画
    With rgbImgDataWork(intRGBImgDataWorkY, intRGBImgDataWorkX)
        .rgbBlue = 0
        .rgbGreen = 0
        .rgbRed = 0
    End With

    ' 幅方向の描画
    If intWidth > 1 Then
        With rgbImgDataWork(intRGBImgDataWorkY, intRGBImgDataWorkX + 1)
            .rgbBlue = 0
            .rgbGreen = 0
            .rgbRed = 0
        End With
    End If

    ' 高さ方向の描画
    If intHeight > 1 Then
        With rgbImgDataWork(intRGBImgDataWorkY + 1, intRGBImgDataWorkX)
            .rgbBlue = 0
            .rgbGreen = 0
            .rgbRed = 0
        End With
    End If

    ' 幅と高さの両方が2以上の場合
    If intWidth > 1 And intHeight > 1 Then
        With rgbImgDataWork(intRGBImgDataWorkY + 1, intRGBImgDataWorkX + 1)
            .rgbBlue = 0
            .rgbGreen = 0
            .rgbRed = 0
        End With
    End If
End Sub



Sub bc_1Dms(xBC As String)
 Dim xShape As Shape, xBkgr As Shape
 Dim xSheet As Worksheet
 Dim xRange As Range, xCell As Range
 Dim xAddr As String
 Dim xPosOldX As Double, xPosOldY As Double
 Dim xSizeOldW As Double, xSizeOldH As Double
' Dim xGrp As ShapeRange
 Dim x As Double
 Dim n%, w%, s$, h%, g%
 
 If TypeName(Application.Caller) <> "Range" Then
   Exit Sub
 End If
 Set xSheet = Application.Caller.Worksheet
 Set xRange = Application.Caller
' Set xCell = xRange("A1")
 xAddr = xRange.Address
 xPosOldX = xRange.Left
 xPosOldY = xRange.Top
 xSizeOldW = 0
 xSizeOldH = 0
 s = "BC" & xAddr & "#GR"
 x = 0
 For n = 1 To Len(xBC)
   w = AscL(Mid(xBC, n, 1)) Mod 256
   If (w >= 48 And w <= 57) Then
     w = (w - 48) Mod 5 + 1
   ElseIf (w >= 65 And w <= 69) Then
     w = w - 64
   Else
     w = 0
   End If
   x = x + 1.5 * w
 Next n
 If x <= 0# Then Exit Sub
 On Error Resume Next
 Set xShape = xSheet.Shapes(s)
 On Error GoTo 0
 If Not (xShape Is Nothing) Then
   xPosOldX = xShape.Left
   xPosOldY = xShape.Top
   xSizeOldW = xShape.Width
   xSizeOldH = xShape.Height
   xShape.Delete
 End If
 On Error Resume Next
 xSheet.Shapes("BC" & xAddr & "#BK").Delete
 On Error GoTo 0
 Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, 51#)
 xBkgr.Line.Visible = msoFalse
 xBkgr.Line.Weight = 0#
 xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Fill.Solid
 xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Name = "BC" & xAddr & "#BK"
 Set xShape = Nothing
 x = 0#
 g = 0
 For n = 1 To Len(xBC)
   w = AscL(Mid(xBC, n, 1)) Mod 256
   If (w >= 48 And w <= 57) Then
     If w >= 53 Then h = 47 Else h = 50
     w = (w - 48) Mod 5 + 1
     Set xShape = xSheet.Shapes.AddShape(msoShapeRectangle, x, 0, 1.5 * w, h)
     xShape.Line.Visible = msoFalse
     xShape.Line.Weight = 0#
     xShape.Fill.Solid
     xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)
     g = g + 1
     xShape.Name = "BC" & xAddr & "#BR" & g
     If g = 1 Then
       xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s
     Else
       xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s
     End If
   ElseIf (w >= 65 And w <= 69) Then
     w = w - 64
   Else
     w = 0
   End If
   x = x + 1.5 * w
 Next n
 On Error Resume Next
 Set xShape = xSheet.Shapes(s)
 On Error GoTo 0
 If Not (xShape Is Nothing) Then
   xShape.Left = xPosOldX
   xShape.Top = xPosOldY
   If xSizeOldW > 0 Then
     xShape.Width = xSizeOldW
     xShape.Height = xSizeOldH
   End If
 Else
   If Not (xBkgr Is Nothing) Then xBkgr.Delete
 End If
End Sub


'----From https://github.com/JonasHeidelberg/barcode-vba-macro-only --- From ---
Sub DrawQRCode(xBC As String, workSheetName As String, rangeName As String, Optional xNam As String)
 Dim xShape As Shape, xBkgr As Shape
 Dim xSheet As Worksheet
 Dim xRange As Range, xCell As Range
 Dim xAddr As String
 Dim xPosOldX As Double, xPosOldY As Double
 Dim xSizeOldW As Double, xSizeOldH As Double
 Dim x, y, m, dm, a As Double
 Dim b%, n%, w%, p$, s$, h%, g%

Set xSheet = Worksheets(workSheetName)
Set xRange = Worksheets(workSheetName).Range(rangeName)
xAddr = xRange.Address
xPosOldX = xRange.Left
xPosOldY = xRange.Top

 xSizeOldW = 0
 xSizeOldH = 0
 s = "BC" & xAddr & "#GR"
 x = 0#
 y = 0#
 m = 2.5
 dm = m * 2#
 a = 0#
 p = Trim(xBC)
 b = Len(p)
 
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If (w >= 97 And w <= 112) Then
     a = a + dm
   ElseIf w = 10 Or n = b Then
     If x < a Then x = a
     y = y + dm
     a = 0#
   End If
 Next n
 If x <= 0# Then Exit Sub
 On Error Resume Next
 Set xShape = xSheet.Shapes(s)
 On Error GoTo 0
 If Not (xShape Is Nothing) Then
   xPosOldX = xShape.Left
   xPosOldY = xShape.Top
   xSizeOldW = xShape.Width
   xSizeOldH = xShape.Height
   xShape.Delete
 End If
 On Error Resume Next
 xSheet.Shapes("BC" & xAddr & "#BK").Delete
 On Error GoTo 0
 Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, y)
 xBkgr.Line.Visible = msoFalse
 xBkgr.Line.Weight = 0#
 xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Fill.Solid
 xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255)
 xBkgr.Name = "BC" & xAddr & "#BK"
 Set xShape = Nothing
 x = 0#
 y = 0#
 g = 0
 For n = 1 To b
   w = AscL(Mid(p, n, 1)) Mod 256
   If w = 10 Then
     y = y + dm
     x = 0#
   ElseIf (w >= 97 And w <= 112) Then
     w = w - 97
     With xSheet.Shapes
     Select Case w
       Case 1: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
       Case 2: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
       Case 3: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
       Case 4: Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
       Case 5: Set xShape = .AddShape(msoShapeRectangle, x, y, m, dm): GoSub fmtxshape
       Case 6: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
               Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
       Case 7: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
               Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape
       Case 8: Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
       Case 9: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
               Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
       Case 10: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, dm): GoSub fmtxshape
       Case 11: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape
                Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape
       Case 12: Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
       Case 13: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape
                Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
       Case 14: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape
                Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape
       Case 15: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, dm): GoSub fmtxshape
     End Select
     End With
     x = x + dm
   End If
 Next n
 On Error Resume Next
 Set xShape = xSheet.Shapes(s)
 On Error GoTo 0
 If Not (xShape Is Nothing) Then
   xShape.Left = xPosOldX
   xShape.Top = xPosOldY
   If xSizeOldW > 0 Then
     xShape.Width = xSizeOldW
     xShape.Height = xSizeOldH
   End If
 Else
   If Not (xBkgr Is Nothing) Then xBkgr.Delete
 End If
 Exit Sub
fmtxshape:
  xShape.Line.Visible = msoFalse
  xShape.Line.Weight = 0#
  xShape.Fill.Solid
  xShape.Fill.ForeColor.RGB = RGB(0, 0, 0)
  g = g + 1
  xShape.Name = "BC" & xAddr & "#BR" & g
  If g = 1 Then
    xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s
  Else
    xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s
  End If
  Return

End Sub
'----From https://github.com/JonasHeidelberg/barcode-vba-macro-only --- End ---
```

# 1-2
## clsWorkSheetForQR
```
'clsQRUTF8 を使って、ワークシート上の指定セルにQRCodeのBMP画像を貼り付けるためのクラス

Option Explicit


'''<remarks>
'''引用元 https://www.limecode.jp/entry/tools/shapes-selectall-intersect-range
'''</remarks>
Private Sub subDeletePictureShapeInRange( _
    ByRef rngTarget As Range, _
    ByVal strShapeName As String _
    )

    '判定用
    Dim rngtopLeft As Range
    Dim rngbottomRight As Range
    Dim blnisInside As Boolean
    
    'デバッグ表示用
    Dim strTemp As String
    
    '13  msoPicture  画像
    Dim shpNow As Shape
    For Each shpNow In rngTarget.Worksheet.Shapes

        ' 図形を指定 (例: Sheet1のShape1) shpNow
    
        ' 判定対象の範囲を指定 (例: Sheet1のA1:C3) rngTarget
    
        ' 図形の左上と右下の座標を取得
        Set rngtopLeft = shpNow.TopLeftCell
        Set rngbottomRight = shpNow.BottomRightCell
    
        'rngTargetの範囲内にあるかどうかを Intersectメソッドで判定
        
        On Error GoTo ErrLabel ' エラーラベルへ
        blnisInside = Not Application.Intersect(rngTarget, Range(rngtopLeft, rngbottomRight)) Is Nothing
        
    
        'デバッグ表示
        If (False) Then
            strTemp = shpNow.Name & ":" & CStr(shpNow.Type) & ":" & CStr(blnisInside)
            Debug.Print (strTemp)
        End If
        ' 結果を表示
        If blnisInside = True Then
            '種類がBMPインポートでの画像取り込みでつくられたシェイプかどうかを判定
            If (shpNow.Type = msoPicture) Then
                'このclsWorkSheetForQRで作られた名前かどうかを判定
                If (shpNow.Name = strShapeName) Then
                    '次の処理で挿入して多重にならないように、既存のシェイプを削除する
                    shpNow.Delete
                End If
            End If
        End If
        
    Next
    
    On Error GoTo 0 ' エラー処理を元に戻す
    
    Exit Sub
    
ErrLabel:
    Dim strMessage As String
    
    strMessage = "Err:(" & err.Number & ")" & err.Description
    MsgBox strMessage, vbExclamation, "subDeletePictureShapeInRange()"
    Resume Next
    
End Sub

'''<summary>
'''画像ファイルをセルに挿入する
'''</summary>
Public Function fncLoadImgFileAndPaste2Cell( _
    shtTarget As Worksheet, _
    rngTarget As Range, _
    ByVal strTargetFilePath As String _
    ) As Shape
    
    Dim shpImage As Shape
        
    ' 図形として画像を挿入
    Set shpImage = shtTarget.Shapes.AddPicture( _
      Filename:=strTargetFilePath, _
      LinkToFile:=msoFalse, _
      SaveWithDocument:=msoTrue, _
      Left:=rngTarget.Left, _
      Top:=rngTarget.Top, _
      Width:=rngTarget.Width, _
      Height:=rngTarget.Height _
      )
        
    Set fncLoadImgFileAndPaste2Cell = shpImage
        
End Function


' <summary>
' この関数は指定されたワークシートの印刷範囲を取得します。
' 印刷範囲が設定されていない場合は、デフォルトの範囲を返します。
' </summary>
Public Function fncGetPrintAreaOrDefault( _
    ws As Worksheet _
    , Optional DefaultRange As String = "" _
    ) As String
    On Error Resume Next ' エラーをスキップ
    Dim PrintArea As String
    
    ' 印刷範囲を取得
    PrintArea = ws.PageSetup.PrintArea
    On Error GoTo 0 ' エラー処理を元に戻す
    
    ' 印刷範囲が存在しない場合はデフォルトの範囲を返す
    If PrintArea = "" Then
        If DefaultRange <> "" Then
            fncGetPrintAreaOrDefault = DefaultRange
        Else
            fncGetPrintAreaOrDefault = "No Print Area Set"
        End If
    Else
        fncGetPrintAreaOrDefault = PrintArea
    End If
End Function



' <summary>
' この関数は、指定されたセルが結合セルであり、その先頭セルかどうかを判定します。
' 結合セルでない場合は True を返します。
' </summary>
' <param name="cell">判定対象のセル (Range オブジェクト)</param>
' <returns>True: 結合セルの先頭、または結合されていないセル。False: 結合セルの先頭以外。</returns>
Public Function fncIsTopCell(rngCell As Range) As Boolean
    Dim topCell As Range
    
    '戻り値
    Dim blnResult As Boolean
    blnResult = False

    ' 結合セルかどうかをチェック
    If rngCell.MergeCells Then
        ' 結合セルの先頭セルを取得
        Set topCell = rngCell.MergeArea.Cells(1, 1)
        
        ' 現在のセルが先頭セルかを判定
        If rngCell.Address = topCell.Address Then
            blnResult = True
        Else
            blnResult = False
        End If
    Else
        ' 結合セルでない場合は True を返す
        blnResult = True
    End If
    
    '関数の戻り値処理
    fncIsTopCell = blnResult
End Function


' <summary>
' この関数は、指定されたセルの縦横から小さい方のサイズを得ます
' 結合セルの場合は結合全体で計測します
' </summary>
Public Function fncGetCellSizeParam(rngCell As Range) As Double

    Dim dblResult As Double
    Dim dblColumnWidth As Double
    Dim dblRowHeight  As Double
    
    '戻り値
    Dim blnResult As Boolean
    blnResult = False

    ' 結合セルかどうかをチェック
    Select Case rngCell.MergeCells
        Case True
            '結合
            dblColumnWidth = rngCell.ColumnWidth
            
            With rngCell
                dblRowHeight = .Cells(.Count).Offset(1, 0).Top - .Top
                dblColumnWidth = .Cells(.Count).Offset(0, 1).Left - .Left
            End With
        
        Case Else
            '通常
            dblRowHeight = rngCell.Height
            dblColumnWidth = rngCell.Width
    End Select
    
    If dblRowHeight < dblColumnWidth Then
        dblResult = dblRowHeight
    Else
        dblResult = dblColumnWidth
    End If
    
    fncGetCellSizeParam = dblResult
        
End Function

'指定ファイルをFileSytemObjectを使って削除する
Private Sub subDelteFile( _
    ByVal strFilePath As String _
    )

    Dim objFSO As Object
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    If objFSO.FileExists(strFilePath) Then
        Call objFSO.DeleteFile(strFilePath)
    End If
    Set objFSO = Nothing
End Sub

' <summary>
'ワークシートにclsQRUTF8をつかってQRコードを貼り付ける
' </summary>
Public Sub subGetQRCodeBMPPaste2WorkSheet( _
    ByVal wsTemp As Worksheet, _
    ByVal strDefaultAreaAddress As String, _
    Optional ByVal strKeyWord As String = "QRCodeUTF8", _
    Optional ByVal blnDeleteBMPfile As Boolean = False _
    )
    '処理継続フラグ
    Dim blnContinue As Boolean
    blnContinue = True
    
    '印刷範囲の取得
    If (blnContinue = True) Then
    
        '取得できた作業エリア
        Dim strPrintArea As String
        
        ' 関数を呼び出して印刷範囲を取得
        strPrintArea = fncGetPrintAreaOrDefault(wsTemp, strDefaultAreaAddress)
        '戻り値判定
        If strPrintArea = "" Then
            '中断
            blnContinue = False
        
        End If
        
    End If

    '印刷範囲内の各セルを確認して
    'コメントに指定文字 "QRCodeUTF8"があればそのセルの値を取得する
    'そのセルのアドレスも取得する
    'ブックのあるフォルダにファイルを生成する。 Thisworkbook.path を得て
    'その中に、 "指定文字" + _ アドレス文字 +".bmp" のファイルができるように、ファイルパスを作成する
    If (blnContinue = True) Then
        '処理対象のレンジを作る
        Dim rngSchanArea As Range
        
        ' 上記で得た範囲文字列からRange オブジェクトを作る
        Set rngSchanArea = wsTemp.Range(strPrintArea)
        
        'BMPファイルを出力するフォルダ
        Dim strTargetFolderPath As String
        '「ExcelBookファイルを置いてある場所なら、ファイルも書き込めるだろう」という事同じフォルダを指定する
        ' ワークブックのフォルダパスを取得
        strTargetFolderPath = ThisWorkbook.Path & "\"
        
        'ループ処理様のレンジ
        Dim rngNowCell As Range
        
        'セルのコメントテキスト
        Dim strCommentText As String
        
        'QRコード生成する場合のキーワード
        If (Len(strKeyWord) = 0) Then
            strKeyWord = "QRCodeUTF8"
        End If
        
        ' 範囲内の各セルを確認
        
        'ループ内フラグ
        Dim blnQRCreate As Boolean
        
        'BMPファイルのファイルパス
        Dim strNowBMPFilePath As String
        
        'QRコードに入れる文字列保持用変数
        Dim strData As String
        
        'QRコード生成用のクラス
        Dim clsMyQR As clsQRUTF8
        Set clsMyQR = New clsQRUTF8
        
        '範囲のセルを処理していく
        For Each rngNowCell In rngSchanArea
            'フラグを初期化
            blnQRCreate = False
            strCommentText = ""
            
            ' 結合セルの場合、最初のセルだけを対象にする
            
            If (fncIsTopCell(rngNowCell) = True) Then
                blnQRCreate = True
            End If
            
            If (blnQRCreate = True) Then
                ' コメントを確認
                On Error Resume Next ' エラー処理をスキップ
                strCommentText = rngNowCell.Comment.Text ' コメントの内容を取得
                On Error GoTo 0 ' エラー処理を元に戻す
                ' 指定された文字列を含むコメントがある場合
                If Not IsEmpty(strCommentText) Then
                    If (InStr(strCommentText, strKeyWord) > 0) Then
                        blnQRCreate = True
                    Else
                        blnQRCreate = False
                    End If
                Else
                    blnQRCreate = False
                End If
            
            End If
            
            If (blnQRCreate = True) Then
                Debug.Print (rngNowCell.Address(False, False) & ":" & strCommentText)
                '値を取得　見た目通りを取得したい場合は text 、そうでなければvalue
                strData = rngNowCell.Text
                
                Dim strShapeName As String
                strShapeName = strKeyWord & "_" & rngNowCell.Address(False, False)
                
                ' ファイルパスを作成
                strNowBMPFilePath = strTargetFolderPath & "\" & strShapeName & ".bmp"
                               
                'QRファイルを生成
                'このあたりはbarcode-vba-macro-onlyの処理を実行するための設定
                Dim intShIx As Integer
                intShIx = 1
                Dim strxAddr As String
                strxAddr = "$A$1"
                
                Dim strCode As String
                strCode = rngNowCell.Text
                
                Dim intPbctype As Integer
                intPbctype = 51
                
                Dim intPGraficky As Integer
                intPGraficky = 1
                    
                Dim intPparams As Integer
                intPparams = 1
                
                Dim intPzones As Integer
                intPzones = 3
                
                '出力
                Dim intOutputMode As Integer
                '0:Shape
                '1:Range
                '2:BitMapFile
                intOutputMode = 2
                
                'ワークシートに出力する処理の場合はExcelの表示を一旦止める
                Application.ScreenUpdating = False
                Application.Calculation = xlCalculationManual
                                
                'QRコード画像生成
                strNowBMPFilePath = clsMyQR.EncodeBarcode( _
                    intShIx, _
                    strxAddr, _
                    strCode, _
                    intPbctype, _
                    intPGraficky, _
                    intPparams, _
                    intPzones, _
                    intOutputMode, _
                    strNowBMPFilePath _
                    )
                
                Application.Calculation = xlCalculationAutomatic
                Application.ScreenUpdating = True
                
                
                '貼り付け先に既にシェイプがあったら削除する
                Call subDeletePictureShapeInRange( _
                    rngNowCell, _
                    strShapeName _
                    )
                                
                Dim shpNow As Shape
                '生成できたであろうBMPファイルを貼り付ける
                Set shpNow = fncLoadImgFileAndPaste2Cell( _
                    wsTemp, _
                    rngNowCell, _
                    strNowBMPFilePath _
                    )
                '更新字の削除処理で識別ができるようにshapeに名前を付ける
                shpNow.Name = strShapeName
                
                '正方形QRコードを貼り付けたいので、正方形にするためのサイズを得る
                Dim dblWHSize As Double
                dblWHSize = fncGetCellSizeParam(rngNowCell)
                
                '正方形QRコードとして縦横同じサイズにする
                With shpNow
                    .Width = dblWHSize
                    .Height = dblWHSize
                End With
                
                '作成したBMPファイルを削除する
                '何かに転用したい（HTMLで表示したいなど）場合は削除フラグをFalseにしておく
                If (blnDeleteBMPfile = True) Then
                    Call subDelteFile(strNowBMPFilePath)
                End If
                
            End If

        Next rngNowCell
            
    End If

End Sub



'----From https://github.com/JonasHeidelberg/barcode-vba-macro-only --- Begin ---

Sub Test_RenderQRCode()
    Call RenderQRCode(Application.ActiveSheet.Name, "A2", "Hello World", "mode=M", False)
End Sub


Public Sub RenderQRCode( _
    workSheetName As String, _
    cellLocation As String, _
    textValue As String, _
    Optional s_param As String, _
    Optional addLabel As Boolean _
    )
   Dim s_encoded As String
   Dim xSheet As Worksheet
   Dim QRShapeName As String
   Dim QRLabelName As String

   If IsMissing(s_param) Then
      s_param = "mode=Q"
   End If
   If IsMissing(addLabel) Then
      addLabel = True
   End If
   
   Dim clsMyQRUTF8 As New clsQRUTF8
   s_encoded = clsMyQRUTF8.fncQR_Gen(textValue, s_param)
   Call clsMyQRUTF8.DrawQRCode(s_encoded, workSheetName, cellLocation)

   Set xSheet = Worksheets(workSheetName)
   QRShapeName = "BC" & "$" & Left(cellLocation, 1) _
       & "$" & Right(cellLocation, Len(cellLocation) - 1) & "#GR"

   QRLabelName = QRShapeName & "_Label"

   With xSheet.Shapes(QRShapeName)
       .Width = 120
       .Height = 120
   End With

   On Error Resume Next
   If Not (xSheet.Shapes(QRLabelName) Is Nothing) Then
       xSheet.Shapes(QRLabelName).Delete
   End If

   If addLabel Then
       xSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _
           xSheet.Shapes(QRShapeName).Left + 35, _
           xSheet.Shapes(QRShapeName).Top, _
           Len(textValue) * 6, 30) _
           .Name = QRLabelName
    
       With xSheet.Shapes(QRLabelName)
           .Line.Visible = msoFalse
           .TextFrame2.TextRange.Font.Name = "Arial"
           .TextFrame2.TextRange.Font.Size = 9
           .TextFrame.Characters.Text = textValue
           .TextFrame2.VerticalAnchor = msoAnchorMiddle
       End With
   End If
End Sub

'----From https://github.com/JonasHeidelberg/barcode-vba-macro-only --- End ---


```

# 2
# ボタンクリックなどで、処理を実行する開始用のVBAを作成します
以下は、ワークシートに、開発＞挿入＞ActiveX＞ボタン
![開発挿入ボタン.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3817111/aa768c77-f213-4dbc-b0b4-ec270b9194dc.png)

でButtonQRCreateという名前のボタンを入れて、ボタンのクリックイベントを作って
コードを貼り付ける、類の例です。

```
'ワークシートの印刷範囲を確認して メモがある場所にQRコードを貼り付ける
'開始ボタンのクリックイベント
Private Sub ButtonQRCreate_Click()

    '処理を継続するかどうかのフラグ
    Dim blnContinue As Boolean
    blnContinue = True
    
    'ユーザーhへのメッセージ
    Dim strMessage As String
    strMessage = CDate(Now) & " 印刷範囲内のメモにQRCodeUTF8が記載されているセルの値をQRコードにします。開始。"
    Application.StatusBar = strMessage
    
    '印刷範囲が得られない場合に適用する範囲指定文字列
    Dim strDefaultAreaAddress As String
    strDefaultAreaAddress = "A1:D10"

    Dim wsTemp As Worksheet
    ' 対象となるワークシートを設定します
    Set wsTemp = ThisWorkbook.ActiveSheet
    
    'ワークシートを捜査して印刷範囲内のメモにQRCodeUTF8が記載されているセルの値を
    'clsQRUTF8を通じてQRコードのBMPファイルを作り、セルに貼り付けるクラスを生成します
    Dim clsMyWS As New clsWorkSheetForQR
    'QRコード生成貼り付け処理を実行します。
    Call clsMyWS.subGetQRCodeBMPPaste2WorkSheet( _
        wsTemp, _
        strDefaultAreaAddress _
        )

    strMessage = CDate(Now) & " 印刷範囲内のメモにQRCodeUTF8が記載されているセルの値をQRコードにします。完了。"
    Application.StatusBar = strMessage
    
End Sub

```
# 3
# QRコードにしたい文字列を、QRコードを貼り付けれるExcelのセルの位置に書き込みます

# 4
# QRコードを貼り付けれるExcelのセルにコメント（メモ）を追加し、"QRCodeUTF8"を記入します
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3817111/fa718d55-f388-4316-953d-c60d2b9e6fed.png)

# 5
# (画像生成の処理は、ある程度の時間が必用なため)生成対象のセルを、印刷範囲で限定します
![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3817111/fd2d8c9b-8b8c-42c9-86ef-7c2dfb1140cc.png)

# 6
# 作成したボタンをクリックなどでVBAを実行します。
　（エラーが出る場合は、VBAのエディターでデバッグしながら修正します）
 ![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3817111/cd010cb3-3441-4f40-ab2e-eb0414841efc.png)

　処理を実行します。作成した一連のVBAの処理が想定通りに実行できれば、コメントを追加した部分のセルの値でQRコード画像が生成されて貼り付けられます
 　![image.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/3817111/0653c8e4-22b8-4c67-b52d-ea9fc2999604.png)

# 7
# 作成されたQRコードを、UTF8のエンコードに対応したソフト（QRコードをデコードし、複数種類ある文字のエンコードを自動判定してくれるような機能があるもの）で読み取って、Excelのセルに書き込んだ値が表示されれば成功です。

# 8
# 以降は、利用の例です
　QRコード生成時は、
　通常のExcelワークシートを使って、帳票のレイアウトを作成するように、デザインをします
　QRコード読み取り機器で読み取って伝えたい内容を、
 　Excel上でエラーの無い文字列にします（エラーがあると、QRコード生成処理でエラー中断しがちです）
 QRコードを生成したい部分は概ね正方形になるようにします。
 セルは単体でも、結合でも１つとしてなるべく画像をおさめようとします
 （あまりに小さすぎるとエラーが出ることがあります）

 　読み取り側は、
  　近年のスマートフォンはSHIFT-JIS UTF8 両方を識別して、テキストを表示してくれるようです。
   QRコード対応のハンディスキャナは、USB-HID、USB-COMモードがあるものを使い、
   １文字をキーボードのキー１つのように送信するUSB-HIDの場合は、キーボードにある文字のQRコードまでにします。
   今回の目的である、漢字を使った文字をQRコードで送りたい場合は、USB-COMのシリアル通信で、受信側のアプリケーションにシリアル通信で送信して、受信側でエンコード処理をします。

   受信側でByte配列を文字に変換します。
   dobon.netさんのコードでできたことがあります。
   最初にBOMで判断させ（この時点でUTF8)、判断が付かない場合にJcode.pmを参考にした方法で判断させ（この時点で、SHIFT-JISのような判断結果になったようです）ることで、自動判定ができました。

   https://dobon.net/vb/dotnet/string/detectcode.html

   あとは、アプリケーションに向けて貼り付けます。

 　ExcelでQRコードを作成したい場合、貼り付け先もExcelにしたい場合も多いと思います
  エンコードできた文字データを、WindowsのOSのclipboardにコピーして、
 　アプリケーションに対して SendKeys で貼り付けます。
  Excelは、[F2]で編集モード→ Ctrl+V で貼り付け　→ {Enter}で編集確定　のようにすると、
  人がキーボードタイプしたときのような入力になり、
  WorkSheet_Chenge() イベントがおきます。
   
Excelを使って、漢字入りの文字列のやりとりをする際は、
　複数列を結合して文字列→QRコード→Excelに貼り付けたものを、複数列に展開して、数式で処理
をしたくなると思います
複数列を結合するときは、区切り文字、カンマ','などの文字で結合し
貼り付けられた側も、WorkSheet_Chengeで　カンマを区切り文字として分解して、貼り付けられたセルから隣接するセルに分解できた単語の分だけ貼り付けると便利でした。

Excel(A)で文字列をQRにする
　→Excel(B)に貼り付けて展開してSUMなどで集計してQRにする
 　　→Excel(C)に貼り付けて展開してSUMなどで集計してQRにする
   
といった事で、ピラミッド型にデータを集計することができる可能性があります。