Hi,
Is it possible to generate Datamatrix code with this program?
thank you
Printable View
Hi,
Is it possible to generate Datamatrix code with this program?
thank you
I think this project only creates QR Codes, to create other type of BarCodes you can try the attached project, thats creates more code bars types, including DataMatrix.Quote:
Originally Posted by Scannia
Btw, this sample uses ZXing library as an external dependacy which is a Java behemoth. The library can appraently produce QR Codes too among many other formats *and* its primary target is actually scanning barcodes it seems.Quote:
Originally Posted by gilman
cheers,
</wqw>
Yes, and the sample also allows scan barcodes from filesQuote:
Originally Posted by wqweto
Honestly hope that no one in his right mind decides it's a good idea to use a Java library for about anything and tirelessly search for replacement using *any* other technology (even .Net).Quote:
Originally Posted by gilman
This thread is about being and staying lean, using less code, particularly with small VBx modules, with no dependencies to produce usable and performant solutions.
cheers,
</wqw>
I just posted in the codebank code Barcode & QRCode reader using ZXing
Thanks, but I can't use it in my Access 2016 database and yes, it's too big for me.Quote:
Originally Posted by gilman
I need searching another solution, which is "simple" VB6 code without any external DLL, ActiveX, etc.
Thanks!
hey all. beginner here. Tried to save the generated QRcode into a file
SavePicture Image1.Picture, "c:\share\1.bmp"
but when opened, the error says "file format not supported"? The file size saved is about 28kB though
any help?
The QR barcode image is generated to a vector picture.
Try using C:\Share\1.emf or 1.wmf for target filename.
ok great. It's working now with 1.emf extension. Thanks so much!
Dim Pic As StdPictureQuote:
Originally Posted by saturnian
Set Pic = QRCodegenBarcode(Text1.Text, 0, QRCodegenEcc_LOW, 1, 5, , , HScroll1.Value)
'SavePicture Pic, App.Path & "\123.emf" 'it's not bmp format
how to save as bmp,without picture1 control?
'Set Picture1.Picture = GetQrcodePic("123", HScroll1.Value)
Picture1.Picture = QRCodegenBarcode?
It's very easy and you don't need a PictureBox or anything else because there is a dedicated procedure in the module you can use for rasterization.
Just read this issue in the repo itself: https://github.com/wqweto/VbQRCodegen/issues/7
cheers,
</wqw>
why do this? 'lModuleSize = Int((Image1.Width * 15) / (lQrSize * Screen.TwipsPerPixelX) + 0.5)
Why is there a black edge on the top?
Now that the function is normal, is there any way for him to generate a QR code full of squares, instead of rounding it?
https://github.com/wqweto/VbQRCodege...dQRCodegen.bas
Code:SavePicture GetQrCodePic("https://www.vbforums.com", 500), App.Path & "\test4.bmp"
Function GetQrCodePic(Txt As String, Width As Long) As StdPicture
Dim baBarCode() As Byte
Dim lQrSize As Long
Dim lModuleSize As Long
If QRCodegenEncode(Txt, baBarCode) Then
lQrSize = QRCodegenGetSize(baBarCode)
'lModuleSize = Int((Image1.Width * 15) / (lQrSize * Screen.TwipsPerPixelX) + 0.5)
lModuleSize = Int((Width * 15) / (lQrSize * Screen.TwipsPerPixelX) + 0.5)
Set GetQrCodePic = QRCodegenResizePicture(QRCodegenResizePicture(QRCodegenConvertToPicture(baBarCode, vbBlack, ModuleSize:=lModuleSize, SquareModules:=False), Width * 4, Width * 4), Width, Width)
Erase baBarCode
End If
End Function
Please, don't post non-sense in this thread.
The edge of your PrictureBox is controlled by Border property of the PictureBox control, it has nothing to do with lModuleSize = Int((Image1.Width * 15) / (lQrSize * Screen.TwipsPerPixelX) + 0.5) code you are citing.
> Now that the function is normal, is there any way for him to generate a QR code full of squares, instead of rounding it?
You are calling the procedure with SquareModules:=False, what do you expect? Did you try SquareModules:=True?
Edit: Take your time to run and research the test project in test subdirectory before asking more questions, please. Most everything you asked so far is implemented there.
cheers,
</wqw>
i don't use picture1 box,only get pic as stdpicture and savebmp
lModuleSize = Width
Now there won't be an extra black edge.
The data size of lModuleSize has changed, and the status of QR code has not changed.?
Sorry, I currently cannot help you because the comminucation loss is severe. If this module does not work ok for you just find something else to produce QR Codes with.
cheers,
</wqw>
At the beginning, the VB QR module can be used to export the two-dimensional code image, but after saving, it is very small, maybe only 30 X 30 pixels. I don't know how to enlarge it. It took me a lot of time to find a way to enlarge it. Thanks very much.
Thank you very much!
Hi There,Quote:
Originally Posted by saturnian
I did downloaded the mentioned Module, but how to insert the generated code into a Sheet Cell? ppreciate your support & Help
Hi There,
I did download the module, but I'm still unable to upload the QR Code into a Sheet Cell. is there a specific vba Code to use with this module?
Appreciate your support & help.
Hi Wqweto,
I've sent few messages but seems lost somewhere...
Anyway, I downloaded the Module QRgenerator and i have few issues as folows:
1- I'm unable to save the generated code into [ Image1.Picture ] as JPG or PNG, the saved file is unreadable except if you open it with Paintbrush
2- I'm unable to save the Image1.Picture to a Sheet Cell
can you help with this issue? I appreciate your support
Ehab
A very useful package that almost exactly fits my needs. It looks well written.
A minor suggestion: At the github page, please indicate that the code requires the Windows libraries (I initially tried to use this on a Mac). Also note whatever restrictions there are (Visual Studio, perhaps) on the test case example (The .frm file fails to load in my Win10 system, with an error about the class used.)
Tl:DR; I don't know how to create (and access) objects at run time that have the Image property that will take the QR image.
Even though I couldn't load the test form, I was able to read its code. So I was able to get this to work with UserForms or with ActiveX forms (but not with non-ActiveX Content Control forms) which I create manually. But, as I'm not proficient at VBA, I've run into a problem that may be trivial for others with experience. Maybe others here can suggest solutions.
I want to create about 200 QR codes from a dynamic source, to be stored in a Word document, for printing. I do not have access to install software on this device (no Visual Studio, etc). With the QR Code generator, I was hoping to programmatically create the QR images in a Word document. I can set the Image field for UserForms and ActiveX pictures, but I've not figured out how to create and access objects with the .Image field that I create at run time. (As far as I am concerned, I don't require a form but just the ability to put the QR code into the file.)
If I can't get past this, I may resort to creating multiple documents from a template file containing ActiveX forms.
FYI, I was able to scale a QR code generated by Nayuki's generator, with a full 4.296 alphanumeric characters (encoding 2864 bytes), to 1.25" (3.175 cm) square, print, scan, and read the QR code from the scan perfectly. That suggests that I can pack about 68kB of binary data per letter-sized page. (I've not done this using this VBA QR code generator yet, but I feel comfortable expecting it will work.)
> A minor suggestion: At the github page, please indicate that the code requires the Windows libraries (I initially tried to use this on a Mac). Also note whatever restrictions there are (Visual Studio, perhaps) on the test case example (The .frm file fails to load in my Win10 system, with an error about the class used.)
Just added a scary README for all the VBA users. . .
> Maybe others here can suggest solutions.
You can create 200 image files (.wmf vectors) which you can then drag&drop in MS Word or you can automate MS Word and copy/paste each vector image w/ QR Code on separate page.
cheers,
</wqw>
Good job , Thankssssssssssssssssss
Hello, is there a way to generate QR codes and paste them directly into Excel worksheet cells?
@ycz22: Ask ChatGPT or your preferred LLM.
Find a solution:
Code:Public Function QRCcodeToWorksheet(pict As stdole.StdPicture, topLeftCell As Range)
Dim oleObj As OLEObject, shapeObj As Shape
'????????????????
For Each shapeObj In Sheets(topLeftCell.Parent.Name).Shapes
If shapeObj.Name = "QRCcode" Then
shapeObj.Delete
Exit For
End If
Next
'?? OLEObjects ???? StdPicture ???????????
Set oleObj = Sheets(topLeftCell.Parent.Name).OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=topLeftCell.Left, Top:=topLeftCell.Top, Width:=pict.Width \ 2540, Height:=pict.Height \ 2540)
With oleObj
.Object.Picture = pict
.Object.BorderStyle = 0
.Object.AutoSize = True
.CopyPicture
.Delete
End With
'?????????????
Sheets(topLeftCell.Parent.Name).Paste Destination:=topLeftCell
Set shapeObj = Sheets(topLeftCell.Parent.Name).Shapes(Sheets(topLeftCell.Parent.Name).Shapes.count)
With shapeObj
.Name = "QRCcode"
.Top = topLeftCell.Top
.Left = topLeftCell.Left
.LockAspectRatio = msoTrue
End With
End Function
That's some code I wouldn't inflict on anyone!
Every time adding a dummy Forms.Image.1 OLE object only to copy/paste an StdPicture into the destination cell seems like beyond overkill.
cheers,
</wqw>
This method copies it to the clipboard and directly pastes it onto the worksheetCode:Option Explicit
'==================================================================
' ?????API ??
'==================================================================
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function PlayEnhMetaFile Lib "gdi32" (ByVal hDC As LongPtr, ByVal hEMF As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function PatBlt Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef picDesc As GUID_UOID, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As stdole.IPicture) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
'==================================================================
' ??????????
'==================================================================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type GUID_UOID
cbSizeOfStruct As Long
picType As Long
hPic As LongPtr
hPal As LongPtr
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'==================================================================
' ?????????
'==================================================================
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const WHITENESS = &HFF0064
Private Const TWIPS_PER_INCH As Long = 2540
'==================================================================
' ?????????
'==================================================================
Public Function ConvertToBitmap(srcPicture As stdole.StdPicture, Optional CopyToClipboard As Boolean = False) As stdole.StdPicture
Dim hResultBitmap As LongPtr
Dim picDesc As GUID_UOID
Dim tGuid As GUID
Dim tRect As RECT
Dim hdcScreen As LongPtr, hdcMem As LongPtr
Dim lngWidth As Long, lngHeight As Long
Dim dpiX As Long, dpiY As Long
Dim hSrcHandle As LongPtr
' --- ??? ---
On Error Resume Next
Set ConvertToBitmap = Nothing
If srcPicture Is Nothing Then Exit Function
hSrcHandle = srcPicture.handle
If hSrcHandle = 0 Then Exit Function
' --- ????: ???????? ---
If srcPicture.Type = 1 Then ' ?????
' ??????
hResultBitmap = CopyImage(hSrcHandle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else ' ??? (EMF/WMF) - ?????
hdcScreen = GetDC(0)
If hdcScreen = 0 Then Exit Function
' ?? DPI (???????)
dpiX = GetDeviceCaps(hdcScreen, LOGPIXELSX)
dpiY = GetDeviceCaps(hdcScreen, LOGPIXELSY)
' --- ????????????? ---
lngWidth = (srcPicture.width * dpiX) / TWIPS_PER_INCH
lngHeight = (srcPicture.height * dpiY) / TWIPS_PER_INCH
' ??????
lngWidth = IIf(lngWidth < 50, 100, lngWidth)
lngHeight = IIf(lngHeight < 50, 100, lngHeight)
tRect.Right = lngWidth
tRect.Bottom = lngHeight
' --- ?????? ---
hdcMem = CreateCompatibleDC(hdcScreen)
If hdcMem = 0 Then GoTo Cleanup
hResultBitmap = CreateCompatibleBitmap(hdcScreen, lngWidth, lngHeight)
If hResultBitmap = 0 Then GoTo Cleanup
Dim hOld As LongPtr
hOld = SelectObject(hdcMem, hResultBitmap)
' --- ???? ---
PatBlt hdcMem, 0, 0, lngWidth, lngHeight, WHITENESS
' --- ????? ---
PlayEnhMetaFile hdcMem, hSrcHandle, tRect
' --- ???? ---
SelectObject hdcMem, hOld
End If
' --- ???? (????) ---
' ??? hdcMem ????????
Cleanup:
If hdcMem <> 0 Then
DeleteDC hdcMem
End If
If hdcScreen <> 0 Then
ReleaseDC 0, hdcScreen
End If
' --- ??????? ---
If hResultBitmap = 0 Then Exit Function
' --- ??? StdPicture ---
With picDesc
.cbSizeOfStruct = LenB(picDesc)
.picType = 1
.hPic = hResultBitmap
.hPal = 0
End With
' --- ???????? GUID ---
' ???????? IPicture GUID
With tGuid
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = 0
.Data4(3) = &HAA
.Data4(4) = 0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
' --- ???? ---
If OleCreatePictureIndirect(picDesc, tGuid, True, ConvertToBitmap) = 0 Then
' --- ????? ---
If CopyToClipboard Then
Dim hClip As LongPtr
hClip = CopyImage(ConvertToBitmap.handle, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
If hClip <> 0 Then
CloseClipboard
If OpenClipboard(0) Then
EmptyClipboard
SetClipboardData CF_BITMAP, hClip
CloseClipboard
End If
End If
End If
End If
End Function
For Excel users who prefer not to use APIs in their spreadsheets, it's possible to export the QR code as a vector image and then import it. A great option is the EPS format whitch is in plain text easy to write and widely supported by softwares including older versions of Excel.
Place QRBarcode in Qr main module and remove all Apis and theirs dependies, Now need to find a VBA version of the UTF-8 conversion function which shouldn't be hard to find, and everything will work fine.
Code:Public Sub QRBarcode(ByVal Target As Range, TextOrByteArray As Variant, _
Optional ByVal ModuleSize As Long = 120, _
Optional ByVal Ecl As QRCodegenEcc = QRCodegenEcc_MEDIUM)
Dim baQrCode() As Byte
Dim picName As String
picName = "QrEpsImage" & Target.Address(0, 0)
On Error Resume Next
Target.Worksheet.Shapes(picName).Delete
On Error GoTo 0
If IsEmpty(TextOrByteArray) Then Exit Sub
If QRCodegenEncode(TextOrByteArray, baQrCode, Ecl, VERSION_MIN, VERSION_MAX, QRCodegenMask_5, True) Then
Dim QrSize As Long
Dim lX As Long
Dim lY As Long
Dim rc As Long, TxtOut() As String, Pz As Long
On Error GoTo nEnd
QrSize = QRCodegenGetSize(baQrCode)
ReDim TxtOut(0 To UBound(baQrCode) + 30)
rc = ModuleSize / (QrSize + 2)
TxtOut(0) = "%!PS-Adobe-3.0 EPSF-3.0"
TxtOut(1) = "%%BoundingBox: 0 0 " & ModuleSize & " " & ModuleSize
TxtOut(2) = "/dt " & rc & " def"
TxtOut(3) = "/rc {moveto dt 0 rlineto 0 dt rlineto dt neg 0 rlineto closepath fill 0 setgray} bind def"
Pz = 4
For lY = 0 To QrSize - 1
For lX = 0 To QrSize - 1
' If baQrCode(lY * QrSize + lX + 1) <> 0 Then
If QRCodegenGetModule(baQrCode, lX, lY) Then
TxtOut(Pz) = (lX + 1) * rc & " " & (lY + 1) * rc & " rc"
Pz = Pz + 1
End If
Next
Next
TxtOut(Pz) = "%%EOF"
ReDim Preserve TxtOut(0 To Pz)
Dim Pic As Object, f As Integer, EpsFile As String
EpsFile = Environ("Tmp") & "\Qr.eps"
f = FreeFile
Open EpsFile For Output As #f
Print #f, Join(TxtOut, Chr(10))
Close #f
Set Pic = Target.Worksheet.Shapes.AddPicture(EpsFile, False, True, 0, 0, 0, 0)
Pic.LockAspectRatio = True
Pic.Name = picName
With Target
Pic.Width = Application.Min(.Width, .Height)
Pic.Top = .Top
Pic.Left = .Left
End With
nEnd: If Err Then
MsgBox Err.Description, vbExclamation
End
End If
End If
End Sub
usage:
Generated file:Code:QRBarcode Range("A1"), "hello !"
Code:%!PS-Adobe-3.0 EPSF-3.0
%%BoundingBox: 0 0 120 120
/dt 5 def
/rc {moveto dt 0 rlineto 0 dt rlineto dt neg 0 rlineto closepath fill 0 setgray} bind def
5 5 rc
10 5 rc
15 5 rc
20 5 rc
25 5 rc
30 5 rc
35 5 rc
45 5 rc
55 5 rc
60 5 rc
65 5 rc
75 5 rc
80 5 rc
85 5 rc
90 5 rc
95 5 rc
100 5 rc
105 5 rc
5 10 rc
35 10 rc
50 10 rc
75 10 rc
105 10 rc
5 15 rc
15 15 rc
20 15 rc
25 15 rc
35 15 rc
45 15 rc
50 15 rc
60 15 rc
65 15 rc
75 15 rc
85 15 rc
90 15 rc
95 15 rc
105 15 rc
5 20 rc
15 20 rc
20 20 rc
25 20 rc
35 20 rc
50 20 rc
55 20 rc
60 20 rc
65 20 rc
75 20 rc
85 20 rc
90 20 rc
95 20 rc
105 20 rc
5 25 rc
15 25 rc
20 25 rc
25 25 rc
35 25 rc
45 25 rc
50 25 rc
55 25 rc
65 25 rc
75 25 rc
85 25 rc
90 25 rc
95 25 rc
105 25 rc
5 30 rc
35 30 rc
50 30 rc
60 30 rc
65 30 rc
75 30 rc
105 30 rc
5 35 rc
10 35 rc
15 35 rc
20 35 rc
25 35 rc
30 35 rc
35 35 rc
45 35 rc
55 35 rc
65 35 rc
75 35 rc
80 35 rc
85 35 rc
90 35 rc
95 35 rc
100 35 rc
105 35 rc
45 40 rc
50 40 rc
65 40 rc
30 45 rc
35 45 rc
50 45 rc
65 45 rc
75 45 rc
85 45 rc
95 45 rc
105 45 rc
5 50 rc
15 50 rc
20 50 rc
30 50 rc
45 50 rc
65 50 rc
85 50 rc
90 50 rc
95 50 rc
5 55 rc
10 55 rc
25 55 rc
35 55 rc
45 55 rc
65 55 rc
75 55 rc
80 55 rc
90 55 rc
95 55 rc
100 55 rc
15 60 rc
20 60 rc
40 60 rc
50 60 rc
75 60 rc
80 60 rc
90 60 rc
95 60 rc
5 65 rc
10 65 rc
15 65 rc
35 65 rc
45 65 rc
50 65 rc
60 65 rc
70 65 rc
75 65 rc
80 65 rc
85 65 rc
90 65 rc
100 65 rc
45 70 rc
50 70 rc
75 70 rc
85 70 rc
90 70 rc
105 70 rc
5 75 rc
10 75 rc
15 75 rc
20 75 rc
25 75 rc
30 75 rc
35 75 rc
65 75 rc
80 75 rc
95 75 rc
100 75 rc
5 80 rc
35 80 rc
45 80 rc
55 80 rc
60 80 rc
65 80 rc
70 80 rc
85 80 rc
90 80 rc
95 80 rc
100 80 rc
5 85 rc
15 85 rc
20 85 rc
25 85 rc
35 85 rc
55 85 rc
65 85 rc
70 85 rc
75 85 rc
80 85 rc
100 85 rc
5 90 rc
15 90 rc
20 90 rc
25 90 rc
35 90 rc
50 90 rc
55 90 rc
60 90 rc
85 90 rc
90 90 rc
5 95 rc
15 95 rc
20 95 rc
25 95 rc
35 95 rc
60 95 rc
80 95 rc
85 95 rc
90 95 rc
95 95 rc
100 95 rc
105 95 rc
5 100 rc
35 100 rc
60 100 rc
65 100 rc
80 100 rc
85 100 rc
90 100 rc
95 100 rc
5 105 rc
10 105 rc
15 105 rc
20 105 rc
25 105 rc
30 105 rc
35 105 rc
50 105 rc
55 105 rc
65 105 rc
70 105 rc
75 105 rc
85 105 rc
100 105 rc
%%EOF
Keep in mind that this EPS export outputs squares and not contiguous poligons like the original WMF does. There might appear gaps between the squares depending on the EPS on-screen renderer used.
cheers,
</wqw>
Hi,
[..]
New version:
Usage:Code:Public Sub QRBarcode(ByVal Target As Range, TextOrByteArray As Variant, _
Optional ByVal ForeColor As Long = vbBlack, _
Optional ByVal QrWidth As Single = 100, _
Optional ByVal QuickSmooth As Boolean = True)
Dim baQrCode() As Byte
Dim picName As String
picName = "QrEpsImage" & Target.Address(0, 0)
On Error Resume Next
Target.Worksheet.Shapes(picName).Delete
On Error GoTo 0
If IsEmpty(TextOrByteArray) Then Exit Sub
On Error GoTo nEnd
Dim Pic As Object, f As Integer, EpsFile As String
EpsFile = Environ("Tmp") & "\Qr.eps"
If Not QRCodegenEpsFile(TextOrByteArray, EpsFile, ForeColor, QrWidth, QuickSmooth, Mask:=QRCodegenMask_5) Then
Exit Sub
End If
Set Pic = Target.Worksheet.Shapes.AddPicture(EpsFile, False, True, 0, 0, 0, 0)
Pic.LockAspectRatio = True
Pic.Name = picName
With Target
Pic.Width = Application.Min(.Width, .Height)
Pic.Top = .Top
Pic.Left = .Left
End With
nEnd:
If Err Then
MsgBox Err.Description, vbExclamation
Application.EnableEvents = True
Application.ScreenUpdating = True
End
End If
End Sub
Private Function QRCodegenEpsFile(TextOrByteArray As Variant, _
ByVal Filename As String, _
Optional ByVal ForeColor As OLE_COLOR = vbBlack, _
Optional ByVal QrWidth As Single = 100, _
Optional ByVal QuickSmooth As Boolean = False, _
Optional ByVal Ecl As QRCodegenEcc = QRCodegenEcc_LOW, _
Optional ByVal MinVersion As Long = VERSION_MIN, _
Optional ByVal MaxVersion As Long = VERSION_MAX, _
Optional ByVal Mask As QRCodegenMask = QRCodegenMask_AUTO, _
Optional ByVal BoostEcl As Boolean = True) As Boolean
Dim baQrCode() As Byte
Dim uVectors() As RECT
Dim uPoints() As POINTAPI
Dim aSizes() As Long
Dim lQrSize As Long
Dim lIdx As Long
Dim ModuleSize As Long
Const PointsToTwips = 20#
If Not QRCodegenEncode(TextOrByteArray, baQrCode, Ecl, MinVersion, MaxVersion, Mask, BoostEcl) Then
Exit Function
End If
lQrSize = QRCodegenGetSize(baQrCode)
ModuleSize = (QrWidth * PointsToTwips / (lQrSize + 1))
pvConstructVectors baQrCode, True, uVectors
pvConstructPolygons uVectors, ModuleSize, uPoints, aSizes
Dim Polys As Long, TxtOut() As String, Pz As Long
ReDim TxtOut(0 To (UBound(uPoints) * 3 + 30))
TxtOut(0) = "%!PS-Adobe-3.0 EPSF-3.0"
TxtOut(1) = "%%BoundingBox: 0 0 " & QrWidth & " " & QrWidth
TxtOut(2) = "/m {moveto} bind def"
TxtOut(3) = "/l {lineto} bind def"
TxtOut(4) = LTrim(Left(Str$(1 / PointsToTwips), 4) & _
Left(Str$(1 / PointsToTwips), 4)) & " scale"
TxtOut(5) = CStr(ModuleSize \ 2) & " " & CStr(ModuleSize \ 2 + (lQrSize) * ModuleSize) & " translate"
Pz = 6
Dim Curr As POINTAPI, Nxt As POINTAPI, i As Long
Dim Dx As Double, Dy As Double, PtDist As Double, ref As Double
ref = ModuleSize / 5
For Polys = 0 To UBound(aSizes)
If QuickSmooth Then
For i = lIdx To (lIdx + aSizes(Polys) - 2)
Curr = uPoints(i)
Nxt = uPoints(i + 1)
Dx = Nxt.X - Curr.X
Dy = Nxt.Y - Curr.Y
If Abs(Dx) > Abs(Dy) Then
PtDist = ref * Sgn(Dx)
Curr.X = Curr.X + PtDist
Nxt.X = Nxt.X - PtDist
Else
PtDist = ref * Sgn(Dy)
Curr.Y = Curr.Y + PtDist
Nxt.Y = Nxt.Y - PtDist
End If
If i = lIdx Then
TxtOut(Pz) = Curr.X & " " & -Curr.Y & " m"
Else
TxtOut(Pz) = Curr.X & " " & -Curr.Y & " l"
End If
TxtOut(Pz + 1) = Nxt.X & " " & -Nxt.Y & " l"
Pz = Pz + 2
Next
Else
For i = lIdx To (lIdx + aSizes(Polys) - 1)
Curr = uPoints(i)
If i = lIdx Then
TxtOut(Pz) = Curr.X & " " & -Curr.Y & " m"
Else
TxtOut(Pz) = Curr.X & " " & -Curr.Y & " l"
End If
Pz = Pz + 1
Next
End If
lIdx = lIdx + aSizes(Polys)
Next
If ForeColor < 0 Then ForeColor = 0
TxtOut(Pz) = LTrim(Left(Str$((ForeColor And &HFF) / &HFF&), 4)) & _
Left(Str$((ForeColor And &HFF00&) / &HFF00&), 4) & _
Left(Str$((ForeColor And &HFF0000) / &HFF0000), 4) & " setrgbcolor"
TxtOut(Pz + 1) = "eofill"
Pz = Pz + 2
TxtOut(Pz) = "%%EOF"
ReDim Preserve TxtOut(0 To Pz)
Dim f As Integer
f = FreeFile
Open Filename For Output As #f
Print #f, Join(TxtOut, Chr(10))
Close #f
QRCodegenEpsFile = True
End Function
In the new version polygons are generated as expected, but there is small a problem with the rounded modules, it seems that eps doesn't properly support empty polygons and collinear segments they still visible making artifacts on small QRs.Code:QRBarcode Range("A1"), "hello !", QuickSmooth:=True
I switched to simple smoothing by clipping the corners instead, which gives an acceptable result , i tried bezier curves but Excel may load polygons in separate layers which affect applaying the odd-even winding rule.
https://www.vbforums.com/images/ieimages/2026/01/1.jpg
Invalid..
I see you are all down the rabbit hole now :-))
JFYI there is Bezier curves branch at https://github.com/wqweto/VbQRCodege.../bezier-curves which outputs to WMF currently.