利用google提供的Qrcode.exe，改寫成vba+cmd範例(win10，excel x32 x64可用)

以前在這篇有回答過qrcode的問題(2016-12-21)
是利用google線上轉碼功能做的簡易範例
優點是簡單
缺點是要上網，沒網路就用不了，資料多就會超lag
https://www.mobile01.com/topicdetail.php?f=511&t=5019053

在這篇有用lib、dll的簡易範例(2017-01-10)
優點是可離線使用
缺點是程式碼稍微複雜一些，還要註冊lib
https://www.mobile01.com/topicdetail.php?f=511&t=5037106


這幾天找資料意外發現原來google有提供原始碼，還有編譯好的exe檔
(不需上網，可離線執行)
可惜到2013年就停止更新了

好奇下載來玩看看，QrcodeGui.exe(視窗版)，中文可正常編碼
可惜實用性不高，一次只能產生一個圖形






在cmd視窗用qrcode.exe(cmd版)，直接打中文，會變亂碼
用vba直接送出去的文字也不行，(vba是utf16)
qrcode一樣會變亂碼，像下圖這樣






雖然可用chcp指令，檢查修改編碼，但反而會讓win7在cmd視窗出現中文無法輸入的問題




不過，測試後發現，確定qrcode.exe有支援"無bom的utf-8"
所以要讓vba送utf-8文字到cmd視窗給qrcode.exe，最簡單的方式就是用文字檔

'前置作業
一、去google下載檔案，直接最後版本就行
雖然下載的是安裝版，但裝好就變免安裝版，可隨便copy到任何位置、電腦
https://code.google.com/archive/p/qrencode-win32/downloads











Sub qrcodetest()

    Dim report, oldpic As Shape, i As Integer, r As Integer
    Dim qr As String, temppath As String, QrexePath As String, QrArgument As String, temppic As String
    
'二、在"桌面"上手動建立名稱"qrcodetest"的暫存資料匣，可自訂其它名稱、位置
    temppath = Environ("USERPROFILE") & "\Desktop\qrcodetest\"
    'QrexePath = Environ("USERPROFILE") & "\Desktop\qrcodetest\qrcode.exe"
'qrcode.exe的位置，可自訂
    QrexePath = "C:\Program Files (x86)\QRCodeGui\qrcode.exe"
    
'注意：如果想自訂暫存檔案名稱，程式執行前，需100%確定暫存目錄的位置是否正確
'kill指令會在無任何提示下刪除所指定的檔案
    If Dir(temppath & "*_pic.png") <> "" Then Kill temppath & "*_pic.png"
    If Dir(temppath & "qrtxt*.txt") <> "" Then Kill temppath & "qrtxt*.txt"
    
    For i = 1 To 5 '暫訂5筆資料
       
        qr = ActiveSheet.Cells(i, 1).Value
        If qr <> "" Then
            report = StrToUTF8(qr, temppath & "qrtxt" & i & ".txt")
            temppic = temppath & i & "_pic.png"
            QrArgument = " -o " & temppic & " -s 3 -l H < " & temppath & "qrtxt" & i & ".txt"
            'QrArgument = " -o " & temppic & " --foreground=ff0000 --background=FFFFFF -s 3 -l H < " & temppath & "qrtxt" & i & ".txt"
            report = Shell("cmd.exe /c """ & QrexePath & """" & QrArgument, vbHide)
        End If
        
    Next i
            
    Application.Wait (Now + TimeValue("0:00:03"))
 '根據資料多少、電腦效能，調整等待時間
 '這裡主要是等檔案寫入硬碟，跟網路無關(這是離線版的)

    
    temppic = Dir(temppath & "*_pic.png")

    Do While temppic <> ""
        'Debug.Print temppic
        r = Split(temppic, "_")(0)
        
        '刪掉同位置上的舊圖形
        For Each oldpic In ActiveSheet.Shapes
            If oldpic.TopLeftCell.Address = ActiveSheet.Cells(r, 2).Address Then
                oldpic.Delete
            End If
        Next
         
        '插入新圖
        '無內嵌圖片，如有excel檔案格式email需求，原始圖片需一起寄出，或轉成pdf
        'Set q = ActiveSheet.Pictures.Insert(temppath & temppic)
'(20210227更新)因2樓高手ren1244指點，當使用原始檔案email時，無內嵌會使圖片不見
'程式碼修改如下ActiveSheet.Pictures.Insert 改成 ActiveSheet.Shapes.AddPicture
        '有內嵌圖片，不需原始圖片，可原檔email
        Set q = ActiveSheet.Shapes.AddPicture(temppath & temppic, False, True, 1, 1, 1, 1)
        With q '位置、大小
            .Left = ActiveSheet.Cells(r, 2).Left
            .Top = ActiveSheet.Cells(r, 2).Top
            .Height = 100
            .Width = 100
        End With
        temppic = Dir()
    
    Loop
    
 End Sub





Function StrToUTF8(StrUtf16 As String, fileName As String)
'utf16轉成沒bom的utf8
  
    Dim Utf8File As Object
    Set Utf8File = CreateObject("ADODB.Stream")
    Utf8File.Type = 1
    Utf8File.Mode = 3
    Utf8File.Open
  
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .CharSet = "utf-8"
        .Open
        .WriteText StrUtf16
        .Position = 3
        .copyto Utf8File
        .Flush
        .Close
    End With
  
    Utf8File.savetofile fileName, 2
    Utf8File.Flush
  
    Set Utf8File = Nothing
  
End Function

如果要在win10使用，需信任暫存目錄的位置，才能正確執行
=>選項=>信任中心=>信任中心設定
(新增暫存目錄，範例中是桌面上的qrcodetest)




qrcode.exe 還有不少參數可用，詳細請參考說明
在dos(cmd)視窗下，打qrcode.exe --help
修改位置在<符號前面(藍色字體)，前、後、參數之間，都要空一格
QrArgument = " -o " & temppic & " -s 3 -l H < " & temppath & "qrtxt" & i & ".txt"
QrArgument = " -o " & temppic & " --foreground=ff0000 --background=FFFFFF -s 3 -l H < " ……略





[點擊下載]