'###############################################################################################
'# QR Code Macro - Creates QR Code from User Input, powered by the QR Code Generator
'# from the ZXing Project
'# Copyright (C) 2012 Maurice Beumers and Shelby Moore
'#
'# This program is free software; you can redistribute it and/or modify it under the
'# terms of the GNU General Public License as published by the Free Software Foundation;
'# either version 3 of the License, or (at your option) any later version.
'#
'# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
'# without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
'# See the GNU General Public License for more details.
'#
'# For the GNU General Public License, see http://www.gnu.org/licenses/gpl-3.0.
'#
'#
'# BUGFIXES:
'# 03-22-2012 added Support for Win 7 x32 and Win 7 x64
'# 03-23-2012 deleted redundant manual preview reload, reload now forced with textbox update
'# corrected the gpl links, added a link to the online QR generator
'# fixed the textboxes to support multiline input
'# integrated a flag to process only if a connection to the online qr generator exists
'# 06-23-2012 fixed: if the "Save As" dialog is canceled, the macro should not process further
'# added the basic vector processing (tracing)
'# added bitmap conversion: imported RGB to Monochrome
'# improved processing to remove the unnecessary white space around the QR code
'# fixed bug with umlauts: has utf-8 support now for the online url query
'# added booster and grouped the processing to one document action: "Make QR Code"
'# added/fixed: when proxy shape isn't square, the process is stopped (Code isn't readable when streched)
'# added automatic powerclipping, when a square powerclip container is selected
'###############################################################################################
Option Explicit
Private OnlineFile$, LocalFile$, SaveFlag As Boolean
Dim ErrCodeArray(3, 0), CharEncodeArray(2, 0)
'# Updated by Shelby Moore
'# added Support for Win 7 x32 and Win 7 x64
#If VBA7 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String) As Long
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As LongPtr, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As LongPtr) As LongPtr
Private Declare PtrSafe Function WideCharToMultiByte Lib "Kernel32" ( _
ByVal CodePage As LongPtr, ByVal dwflags As LongPtr, _
ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As LongPtr, _
ByVal lpMultiByteStr As LongPtr, ByVal cchMultiByte As LongPtr, _
ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As LongPtr
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String) As Long
Private Declare Function ShellExecute& Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long)
Private Declare Function WideCharToMultiByte Lib "Kernel32" ( _
ByVal CodePage As Long, ByVal dwflags As Long, _
ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
#End If
Const SW_SHOWNORMAL = 1
Private Const CP_UTF8 = 65001
'#####----qr code preview reload by textbox update----#####
Private Sub bAC_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bAdr_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bCC_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bEmail_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bName_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bNote_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bOrg_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bPhone_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bPhoneNmb_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bSMSAC_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bSMSCC_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bSMSPhoneNmb_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bSMSText_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
lMsg.Caption = "Message to enter (curr. length: " & bSMSText.TextLength & "; " & 160 - bSMSText.TextLength & " Chars left.)"
getQRCode
End Sub
Private Sub bText_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
lText.Caption = "Text to enter (curr. length: " & bText.TextLength & "; " & 300 - bText.TextLength & " Chars left.)"
getQRCode
End Sub
Private Sub bTitle_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bToEmail_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bURL_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub bWeb_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
getQRCode
End Sub
Private Sub comboCharEncod_Change()
getQRCode
End Sub
Private Sub comboErrCode_Change()
getQRCode
End Sub
'#####----textbox update ends----#####
Private Sub cmdCreate_Click()
Dim s1 As Shape, s2 As Shape, impopt As StructImportOptions, impflt As ImportFilter, x#, y#, w#, h#, trset As TraceSettings, tsr As ShapeRange, pwr As PowerClip
' If the link to the online generator is empty, we have to asume the boxes are also empty:
If OnlineFile = "" Then: MsgBox "No Data to process yet": GoTo GoOn:
'Oh, we need a valid connection of course!
'Comment the next line out when running in debug mode, cause the "QROnline_DocumentComplete" event doesnt trigger in debug mode
If SaveFlag = False Then: MsgBox "connecting to Online Code Generator. Wait a few seconds or check your internet connection.": GoTo GoOn:
'TURBO!!!
boostStart "Make QR Code"
On Error GoTo ErrorMe:
'If a shape is selected, force the imported qr code image to adopt position and size
If Not ActiveShape Is Nothing Then
Set s1 = ActiveShape
ActiveDocument.ReferencePoint = cdrCenter
s1.GetPosition x, y
s1.GetSize w, h
End If
'No place yet to store the downloaded code image? So promt a window where to save it
If LocalFile = "" Then
LocalFile = Application.CorelScriptTools.GetFileBox("QR Code PNG Image|*.png|All Files|*.*", "Select the destination where to Save and Open The QR Code from", 1, "qrcode.png")
End If
'If the "Save As" dialog was canceled, stop processing
If LocalFile = "" Then GoTo GoOn:
'NOW download the image from the online generator:
DownloadFile
'Import stuff...
Set impopt = CreateStructImportOptions
With impopt
.Mode = cdrImportFull
.MaintainLayers = True
End With
Set impflt = ActiveLayer.ImportEx(LocalFile, cdrAutoSense, impopt)
impflt.Finish
'prepare vector tracing...
If ActiveShape.Type = cdrBitmapShape Then
Set trset = ActiveShape.Bitmap.Trace(cdrTraceClipart, , , cdrColorMixed, cdrCustom, 2, True, True, True)
With trset
.DetailLevelPercent = 100
.BackgroundRemovalMode = cdrTraceBackgroundAutomatic
.CornerSmoothness = 0
.DeleteOriginalObject = True
.RemoveBackground = True
.RemoveEntireBackColor = True
.RemoveOverlap = True
.SetColorCount 2
.SetColorMode cdrColorGray, cdrCustom
.Smoothing = 0
.TraceType = cdrTraceClipart
End With
Set tsr = trset.Finish
tsr.Ungroup
Set s2 = tsr.Combine
End If
'set the code image/shape size and position to the proxy shape, delete the proxy shape
If Not s1 Is Nothing Then
s2.SetPositionEx cdrCenter, x, y
If ImageResize(s2, w, h, x, y) = False Then GoTo GoOn:
If optBitmap = True Then
Set s2 = s2.ConvertToBitmapEx(cdrBlackAndWhiteImage, False, False, ActiveDocument.Resolution, cdrNoAntiAliasing, True)
End If
'check if the proxy shape is a powerclip container, if yes, paste the code image/shape into it
Set pwr = Nothing: Set pwr = s1.PowerClip
On Error GoTo 0
If Not pwr Is Nothing Then
s2.Cut
pwr.EnterEditMode
ActiveLayer.Paste
pwr.LeaveEditMode
Else
s1.Delete
End If
End If
GoOn:
'TURBO END
boostFinish True
Exit Sub
ErrorMe:
'#####################################----ERROR-MESSAGE----##################################################
MsgBox "Error occured: " & Err.Description & Chr(13) & _
"Error Number: " & Err.Number & Chr(13) & _
"Error Source: " & Err.Source & Chr(13) & _
"Error DLL: " & Err.LastDllError & Chr(13)
Err.Clear
Resume GoOn
'######################################----END-MESSAGE----###################################################
End Sub
Private Function getQRCode()
'prepare the URL query for the online generator...
QROnline.Navigate "about:blank"
OnlineFile = "http://chart.apis.google.com/chart?cht=qr&chs=120x120&chld=" & comboErrCode.Value & "&choe=" & comboCharEncod.Value & "&"
Select Case DataType.Value
Case 0
OnlineFile = OnlineFile & "chl=" & URLEncode(bText.Value)
Case 1
OnlineFile = OnlineFile & "chl=" & URLEncode(bURL.Value)
Case 2
OnlineFile = OnlineFile & "chl=" & URLEncode("mailto:" & bToEmail.Value)
Case 3
OnlineFile = OnlineFile & "chl=" & URLEncode("TEL:" & bCC.Value & bAC.Value & bPhoneNmb.Value)
Case 4
OnlineFile = OnlineFile & "chl=" & URLEncode("SMSTO:" & bSMSCC.Value & bSMSAC.Value & bSMSPhoneNmb.Value & ":" & bSMSText.Value)
Case 5
OnlineFile = OnlineFile & "chl=" & URLEncode("BEGIN:VCARD") & "%0A" & _
URLEncode("TEL:" & bPhone.Value) & "%0A" & URLEncode("EMAIL:" & bEmail.Value) & "%0A" & _
URLEncode("URL:" & bWeb.Value) & "%0A" & URLEncode("N:" & bTitle.Value & ";" & bName.Value) & "%0A" & _
URLEncode("ADR:" & bAdr.Value) & "%0A" & _
URLEncode("ORG:" & bOrg.Value) & "%0A" & _
URLEncode("NOTE:" & bNote.Value) & "%0A" & URLEncode("END:VCARD") & "%0A"
End Select
SaveFlag = False
'connect to online generator:
QROnline.Navigate OnlineFile
End Function
Private Sub QROnline_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error Resume Next
'Prevent Scrollbars in the QR Code preview window
QROnline.Document.body.Scroll = "no"
SaveFlag = True
On Error GoTo 0
End Sub
Private Sub UserForm_Initialize()
ErrCodeArray(0, 0) = "L (recommended, low, ~7%)"
ErrCodeArray(1, 0) = "M (middle, ~15%)"
ErrCodeArray(2, 0) = "Q (quality, ~25%)"
ErrCodeArray(3, 0) = "H (high, ~30%)"
comboErrCode.List() = ErrCodeArray
comboErrCode.ControlTipText = "Error Correction Code. Select how many lost data (in percent) should be compensateable."
CharEncodeArray(0, 0) = "UTF-8 (recommended)"
CharEncodeArray(1, 0) = "ISO-8859-1 (ASCII only)"
CharEncodeArray(2, 0) = "SHIFT_JIS (Japanese)"
comboCharEncod.List() = CharEncodeArray
comboCharEncod.ControlTipText = "Charset Code. Use ISO-8859-1 for very old QR Readers."
End Sub
Private Sub UserForm_Activate()
'show a blank preview at startup
QROnline.Navigate "about:blank"
End Sub
Private Function DownloadFile() As Boolean
Dim lngRetVal As Long
'clean up URL-Cache
lngRetVal = DeleteUrlCacheEntry(OnlineFile)
'Screen.MousePointer = vbHourglass
lngRetVal = URLDownloadToFile(0, OnlineFile, LocalFile, 0, 0)
'Screen.MousePointer = vbNormal
If lngRetVal = 0 Then DownloadFile = True
End Function
Private Function ImageResize(s1 As Shape, w#, h#, x#, y#) As Boolean
If w <> h Then
MsgBox "The Proxy Shape must be square in order to create a readable QR Code": ImageResize = False
Else
s1.SizeWidth = w
s1.SizeHeight = h
ImageResize = True
End If
End Function
Private Function UTF16To8(ByVal UTF16 As String) As String
Dim sBuffer As String
Dim lLength As Long
If UTF16 <> "" Then
lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
sBuffer = Space$(lLength)
lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
sBuffer = StrConv(sBuffer, vbUnicode)
UTF16To8 = Left$(sBuffer, lLength - 1)
Else
UTF16To8 = ""
End If
End Function
Private Function URLEncode(StringVal As String, Optional SpaceAsPlus As Boolean = True, Optional UTF8Encode As Boolean = True) As String
' Converting Macro input to an URL Query String
Dim StringValCopy$, StringLen&
StringValCopy = IIf(UTF8Encode, UTF16To8(StringVal), StringVal)
StringLen = Len(StringValCopy)
If StringLen > 0 Then
ReDim Result(StringLen) As String
Dim I As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For I = 1 To StringLen
Char = Mid$(StringValCopy, I, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
Result(I) = Char
Case 32
Result(I) = Space
Case 0 To 15
Result(I) = "%0" & Hex(CharCode)
Case Else
Result(I) = "%" & Hex(CharCode)
End Select
Next I
URLEncode = Join(Result, "")
End If
End Function
Sub boostStart(Optional ByVal unDo As String = "")
On Error Resume Next
If unDo <> "" Then ActiveDocument.BeginCommandGroup unDo
Optimization = True
EventsEnabled = False
ActiveDocument.SaveSettings
'ActiveDocument.PreserveSelection = False
End Sub
Sub boostFinish(Optional ByVal endUndoGroup As Boolean = False)
On Error Resume Next
'ActiveDocument.PreserveSelection = True
ActiveDocument.RestoreSettings
EventsEnabled = True
Optimization = False
ActiveWindow.Refresh
Refresh
If endUndoGroup Then ActiveDocument.EndCommandGroup
End Sub
Private Sub lQRG_Click()
Dim GPLstring$
'opens the link to the online QR Code generator
GPLstring = "http://zxing.appspot.com/generator/"
ShellExecute 0&, "open", GPLstring, vbNullString, vbNullString, SW_SHOWNORMAL
End Sub
Private Sub lGPL_Click()
Dim GPLstring$
'opens the link to the online GPL license
GPLstring = "http://www.gnu.org/licenses/gpl-3.0"
ShellExecute 0&, "open", GPLstring, vbNullString, vbNullString, SW_SHOWNORMAL
End Sub
Private Sub UserForm_Terminate()
Unload Me
End Sub