--- frmQRCM ---
'###############################################################################################
'# QR Code Macro - Creates QR Code from User Input, powered by the QR Code Generator
'# from the ZXing Project
'# Copyright (C) 2012 Maurice Beumers
'#
'# 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
'###############################################################################################
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 ands 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
#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)
#End If
Const SW_SHOWNORMAL = 1
'#####----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)
getQRCode
End Sub
Private Sub bText_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
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
'#####----textbox update ends----#####
Private Sub cmdCreate_Click()
Dim s1 As Shape, impopt As StructImportOptions, impflt As ImportFilter, x#, y#, w#, h#
' 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": Exit Sub
'Oh, we need a valid connection of course!
If SaveFlag = False Then: MsgBox "connecting to Online Code Generator. Wait a few seconds or check your internet connection.": Exit Sub
'If a shape is selected, force the imported 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
On Error GoTo ErrorMe:
'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, "chart.png")
End If
'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
'set the code image size and position to the proxy shape, delete the proxy shape
If Not s1 Is Nothing Then
ActiveShape.SetPositionEx cdrCenter, x, y
ImageResizer ActiveShape, w, h, x, y
'ActiveShape = Nothing
s1.Delete
End If
GoOn:
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"
ErrCodeArray(1, 0) = "M"
ErrCodeArray(2, 0) = "Q"
ErrCodeArray(3, 0) = "H"
comboErrCode.List() = ErrCodeArray
CharEncodeArray(0, 0) = "UTF-8"
CharEncodeArray(1, 0) = "ISO-8859-1"
CharEncodeArray(2, 0) = "SHIFT_JIS"
comboCharEncod.List() = CharEncodeArray
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 ImageResizer(s1 As Shape, w#, h#, x#, y#)
If s1.SizeHeight > s1.SizeWidth Then
s1.SizeWidth = (h / s1.SizeHeight) * s1.SizeWidth
s1.SizeHeight = h
ElseIf s1.SizeWidth > s1.SizeHeight Then
s1.SizeHeight = (w / s1.SizeWidth) * s1.SizeHeight
s1.SizeWidth = w
Else
s1.SizeWidth = w
s1.SizeHeight = h
End If
End Function
Private Function URLEncode(StringToEncode$) As String
' Converting Macro input to an URL Query String
Dim TempAns$, CurChr As Integer
CurChr = 1
Do Until CurChr - 1 = Len(StringToEncode)
Select Case Asc(Mid$(StringToEncode, CurChr, 1))
Case 48 To 57, 65 To 90, 97 To 122
TempAns = TempAns & Mid$(StringToEncode, CurChr, 1)
Case 32
TempAns = TempAns & "+"
Case Else
TempAns = TempAns & "%" & Hex(Asc(Mid$(StringToEncode, CurChr, 1)))
End Select
CurChr = CurChr + 1
Loop
URLEncode = TempAns
End Function
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