-- frQRCM.frm --
'
'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/.
'
Option Explicit
Private OnlineFile$, LocalFile$
Dim ErrCodeArray(3, 0), CharEncodeArray(2, 0)
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)
Const SW_SHOWNORMAL = 1
Private Sub cmdCreate_Click()
Dim s1 As Shape, impopt As StructImportOptions, impflt As ImportFilter, x#, y#, w#, h#
If OnlineFile = "" Then: MsgBox "No Data to process yet": Exit Sub
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:
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
DownloadFile
Set impopt = CreateStructImportOptions
With impopt
.Mode = cdrImportFull
.MaintainLayers = True
End With
Set impflt = ActiveLayer.ImportEx(LocalFile, cdrAutoSense, impopt)
impflt.Finish
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()
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
QROnline.Navigate OnlineFile
QROnline.Document.body.Style.Width = "120px"
QROnline.Document.body.Style.Height = "120px"
QROnline.Document.body.Style.Overflow = "hidden"
End Function
Private Sub QROnline_DocumentComplete(ByVal pDisp As Object, URL As Variant)
On Error Resume Next
QROnline.Document.body.Scroll = "no"
On Error GoTo 0
End Sub
Private Sub lQRPrev_Click()
getQRCode
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()
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
' Converting Macro input to an URL Query String
Public Function URLEncode(StringToEncode$) As 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 lGPL_Click()
Dim GPLstring$
GPLstring = "http://www.gnu.org/licenses/"
ShellExecute 0&, "open", GPLstring, vbNullString, vbNullString, SW_SHOWNORMAL
End Sub
Private Sub UserForm_Terminate()
Unload Me
End Sub