1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
| '*************************************************************************
'
' Code adapté à partir du travail de Vladimir Vissoultchev
' > Source : https://github.com/wqweto/VbQRCodegen
'
'*************************************************************************
'=========================================================================
'
' QR Code generator library (VB6/VBA)
'
' Copyright (c) Project Nayuki. (MIT License)
' https://www.nayuki.io/page/qr-code-generator-library
'
' Copyright (c) wqweto@gmail.com (MIT License)
'
'=========================================================================
Option Explicit
#Const HasPtrSafe = (VBA7 <> 0) Or (TWINBASIC <> 0)
'=========================================================================
' Public enums
'=========================================================================
Public Enum QRCodegenEcc
QRCodegenEcc_LOW = 0 ' The QR Code can tolerate about 7% erroneous codewords
QRCodegenEcc_MEDIUM ' The QR Code can tolerate about 15% erroneous codewords
QRCodegenEcc_QUARTILE ' The QR Code can tolerate about 25% erroneous codewords
QRCodegenEcc_HIGH ' The QR Code can tolerate about 30% erroneous codewords
End Enum
Public Enum QRCodegenMask
QRCodegenMask_AUTO = -1
QRCodegenMask_0 = 0
QRCodegenMask_1
QRCodegenMask_2
QRCodegenMask_3
QRCodegenMask_4
QRCodegenMask_5
QRCodegenMask_6
QRCodegenMask_7
End Enum
Public Enum QRCodegenMode
QRCodegenMode_NUMERIC = &H1
QRCodegenMode_ALPHANUMERIC = &H2
QRCodegenMode_BYTE = &H4
QRCodegenMode_KANJI = &H8
QRCodegenMode_ECI = &H7
End Enum
Private Type QRCodegenSegment
Mode As QRCodegenMode
NumChars As Long
Data() As Byte
BitLength As Long
End Type
'=========================================================================
' API
'=========================================================================
#If HasPtrSafe Then
Private Declare PtrSafe Function CreateEnhMetaFile Lib "gdi32" Alias "CreateEnhMetaFileW" (ByVal hdcRef As LongPtr, ByVal lpFileName As LongPtr, ByVal lpRect As LongPtr, ByVal lpDescription As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseEnhMetaFile Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, lpvObj As IPicture) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As LongPtr, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As stdole.IUnknown
Private Declare PtrSafe Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, lpBitsInfo As Any, ByVal wUsage As Long, lpBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
Private Declare PtrSafe Function SetStretchBltMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nStretchMode As Long) As Long
Private Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function PolyPolygon Lib "gdi32" (ByVal hDC As LongPtr, lpPoint As Any, lpPolyCounts As Any, ByVal nCount As Long) As Long
Private Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hCD As LongPtr, ByVal nMapMode As Long) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function CreateEnhMetaFile Lib "gdi32" Alias "CreateEnhMetaFileW" (ByVal hdcRef As LongPtr, ByVal lpFileName As LongPtr, ByVal lpRect As LongPtr, ByVal lpDescription As LongPtr) As LongPtr
Private Declare Function CloseEnhMetaFile Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, lpvObj As IPicture) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As LongPtr, ByVal lpDefaultChar As LongPtr, ByVal lpUsedDefaultChar As LongPtr) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As stdole.IUnknown
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, lpBitsInfo As Any, ByVal wUsage As Long, lpBits As LongPtr, ByVal hSection As LongPtr, ByVal dwOffset As Long) As LongPtr
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nStretchMode As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hdcSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32" (ByVal hDC As LongPtr, lpPoint As Any, lpPolyCounts As Any, ByVal nCount As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hCD As LongPtr, ByVal nMapMode As Long) As Long
#End If
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PICTDESC
Size As Long
Type As Long
hBmpOrIcon As LongPtr
hPal As LongPtr
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
'=========================================================================
' Constants and member variables
'=========================================================================
Private Const VERSION_MIN As Long = 1
Private Const VERSION_MAX As Long = 40
Private Const PENALTY_N1 As Long = 3
Private Const PENALTY_N2 As Long = 3
Private Const PENALTY_N3 As Long = 40
Private Const PENALTY_N4 As Long = 10
Private Const INT16_MAX As Long = 32767
Private Const LONG_MAX As Long = 2147483647
Private Const ALPHANUMERIC_CHARSET As String = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:"
Private Const M_PI_2 As Double = 3.14159265358979 / 2
Private Const LINE_TO As Long = 1
Private Const TURN_LEFT As Long = 2
Private Const TURN_RIGHT As Long = 3
Private Const WIDE_LEFT As Long = 4
Private Const WIDE_RIGHT As Long = 5
Private Const SUPERWIDE_LEFT As Long = 6 '--- not used
Private Const SUPERWIDE_RIGHT As Long = 7
Private Const SKIP_TO As Long = 8
Private LNG_POW2(0 To 31) As Long
Private ECC_CODEWORDS_PER_BLOCK(0 To 3, 0 To 40) As Long
Private NUM_ERROR_CORRECTION_BLOCKS(0 To 3, 0 To 40) As Long
Private IID_IPicture(0 To 3) As Long '--- 7BF80980-BF32-101A-8BBB-00AA00300CAB
Private IID_IPersistStream(0 To 3) As Long '--- 00000109-0000-0000-C000-000000000046
'=========================================================================
' Functions
'=========================================================================
Public Function QRCodegenBarcode(TextOrByteArray As Variant, _
Optional ByVal ForeColor As OLE_COLOR = vbBlack, _
Optional ByVal ModuleSize As Long = 120, _
Optional ByVal SquareModules As Boolean = True, _
Optional ByVal Ecl As QRCodegenEcc = QRCodegenEcc_MEDIUM, _
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 StdPicture
Dim baQrCode() As Byte
If QRCodegenEncode(TextOrByteArray, baQrCode, Ecl, MinVersion, MaxVersion, Mask, BoostEcl) Then
Set QRCodegenBarcode = QRCodegenConvertToPicture(baQrCode, ForeColor, ModuleSize, SquareModules)
End If
End Function
Private Function QRCodegenEncode(TextOrByteArray As Variant, baQrCode() As Byte, _
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 baData() As Byte
Dim lDataLen As Long
Dim sText As String
Dim lBufLen As Long
Dim uSegments() As QRCodegenSegment
pvInit
If IsArray(TextOrByteArray) Then
baData = TextOrByteArray
lDataLen = UBound(baData) + 1
Else
sText = TextOrByteArray
lDataLen = Len(sText)
End If
If lDataLen = 0 Then
ReDim uSegments(-1 To -1) As QRCodegenSegment
Else
ReDim uSegments(0 To 0) As QRCodegenSegment
lBufLen = pvGetBufferLenForVersion(MaxVersion)
If IsArray(TextOrByteArray) Then
If QRCodegenCalcSegmentBufferSize(QRCodegenMode_BYTE, lDataLen) > lBufLen Then
GoTo QH
End If
uSegments(0) = QRCodegenMakeBytes(baData)
ElseIf QRCodegenIsNumeric(sText) Then
If QRCodegenCalcSegmentBufferSize(QRCodegenMode_NUMERIC, lDataLen) > lBufLen Then
GoTo QH
End If
uSegments(0) = QRCodegenMakeNumeric(sText)
ElseIf QRCodegenIsAlphanumeric(sText) Then
If QRCodegenCalcSegmentBufferSize(QRCodegenMode_ALPHANUMERIC, lDataLen) > lBufLen Then
GoTo QH
End If
uSegments(0) = QRCodegenMakeAlphanumeric(sText)
Else
baData = pvToUtf8Array(sText)
lDataLen = UBound(baData) + 1
If QRCodegenCalcSegmentBufferSize(QRCodegenMode_BYTE, lDataLen) > lBufLen Then
GoTo QH
End If
uSegments(0) = QRCodegenMakeBytes(baData)
End If
End If
QRCodegenEncode = QRCodegenEncodeSegments(uSegments, baQrCode, Ecl, MinVersion, MaxVersion, Mask, BoostEcl)
Exit Function
QH:
ReDim baQrCode(0 To 0) As Byte
End Function
Private Function QRCodegenEncodeSegments(uSegments() As QRCodegenSegment, baQrCode() As Byte, _
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 lVersion As Long
Dim lDataUsedBits As Long
Dim lDataCapacityBits As Long
Dim lIdx As Long
Dim lJdx As Long
Dim lBitLen As Long
Dim lBit As Long
Dim lTerminatorBits As Long
Dim lPadByte As Long
Dim baTemp() As Byte
Dim lMinPenalty As Long
Dim lPenalty As Long
pvInit
'--- Find the minimal version number to use
For lVersion = MinVersion To MaxVersion
lDataCapacityBits = pvGetNumDataCodewords(lVersion, Ecl) * 8
lDataUsedBits = pvGetTotalBits(uSegments, lVersion)
If lDataUsedBits <> -1 And lDataUsedBits <= lDataCapacityBits Then
Exit For
End If
If lVersion >= MaxVersion Then
baQrCode = vbNullString
GoTo QH
End If
Next
Debug.Assert lDataUsedBits <> -1
'--- Increase the error correction level while the data still fits in the current version number
If BoostEcl Then
For lIdx = QRCodegenEcc_MEDIUM To QRCodegenEcc_HIGH
If lDataUsedBits <= pvGetNumDataCodewords(lVersion, lIdx) * 8 Then
Ecl = lIdx
End If
Next
End If
'--- Concatenate all segments to create the data bit string
ReDim baQrCode(0 To pvGetBufferLenForVersion(lVersion) - 1) As Byte
For lIdx = 0 To UBound(uSegments)
With uSegments(lIdx)
pvAppendBitsToBuffer .Mode, 4, baQrCode, lBitLen
pvAppendBitsToBuffer .NumChars, pvNumCharCountBits(.Mode, lVersion), baQrCode, lBitLen
For lJdx = 0 To .BitLength - 1
lBit = -((.Data(lJdx \ 8) And LNG_POW2(7 - (lJdx And 7))) <> 0)
pvAppendBitsToBuffer lBit, 1, baQrCode, lBitLen
Next
End With
Next
Debug.Assert lBitLen = lDataUsedBits
'--- Add terminator and pad up to a byte if applicable
lDataCapacityBits = pvGetNumDataCodewords(lVersion, Ecl) * 8
Debug.Assert lBitLen <= lDataCapacityBits
lTerminatorBits = lDataCapacityBits - lBitLen
If lTerminatorBits > 4 Then
lTerminatorBits = 4
End If
pvAppendBitsToBuffer 0, lTerminatorBits, baQrCode, lBitLen
pvAppendBitsToBuffer 0, (8 - (lBitLen And 7)) And 7, baQrCode, lBitLen
Debug.Assert lBitLen Mod 8 = 0
'--- Pad with alternating bytes until data capacity is reached
lPadByte = &HEC
Do While lBitLen < lDataCapacityBits
pvAppendBitsToBuffer lPadByte, 8, baQrCode, lBitLen
lPadByte = lPadByte Xor (&HEC Xor &H11)
Loop
'--- Compute ECC, draw modules
pvAddEccAndInterleave baQrCode, lVersion, Ecl, baTemp
pvInitializeFunctionModules lVersion, baQrCode
Debug.Assert UBound(baTemp) + 1 = pvGetNumRawDataModules(lVersion) \ 8
pvDrawCodewords baTemp, baQrCode
pvDrawLightFunctionModules lVersion, baQrCode
pvInitializeFunctionModules lVersion, baTemp
'--- Do masking
If Mask = QRCodegenMask_AUTO Then
lMinPenalty = LONG_MAX
For lIdx = QRCodegenMask_0 To QRCodegenMask_7
pvApplyMask baTemp, baQrCode, lIdx
pvDrawFormatBits Ecl, lIdx, baQrCode
lPenalty = pvGetPenaltyScore(baQrCode)
If lPenalty < lMinPenalty Then
Mask = lIdx
lMinPenalty = lPenalty
End If
pvApplyMask baTemp, baQrCode, lIdx '--- Undoes the mask due to XOR
Next
End If
Debug.Assert QRCodegenMask_0 <= Mask And Mask <= QRCodegenMask_7
pvApplyMask baTemp, baQrCode, Mask
pvDrawFormatBits Ecl, Mask, baQrCode
'--- success
QRCodegenEncodeSegments = True
QH:
End Function
Private Function QRCodegenConvertToPicture(baQrCode() As Byte, _
Optional ByVal ForeColor As OLE_COLOR = vbBlack, _
Optional ByVal ModuleSize As Long = 120, _
Optional ByVal SquareModules As Boolean) As StdPicture
Const WHITE_BRUSH As Long = 0
Const NULL_PEN As Long = 8
Const MM_TWIPS As Long = 6
Const vbPicTypeEMetafile As Long = 4
Dim uVectors() As RECT
Dim uPoints() As POINTAPI
Dim aSizes() As Long
Dim lQrSize As Long
Dim hDC As LongPtr
Dim uRect As RECT
Dim hBlackBrush As LongPtr
Dim hPrevBrush As LongPtr
Dim hPrevPen As LongPtr
Dim lIdx As Long
Dim uDesc As PICTDESC
Dim hResult As Long
Dim vErr As Variant
On Error GoTo EH
pvConstructVectors baQrCode, SquareModules, uVectors
pvConstructPolygons uVectors, ModuleSize, uPoints, aSizes
'--- draw polygons to enhanced metafile
lQrSize = QRCodegenGetSize(baQrCode)
hDC = CreateEnhMetaFile(0, 0, 0, 0)
Call SetMapMode(hDC, MM_TWIPS)
uRect.Right = (lQrSize + 1) * ModuleSize
uRect.Bottom = (lQrSize + 1) * ModuleSize
Call FillRect(hDC, uRect, GetStockObject(WHITE_BRUSH))
hBlackBrush = CreateSolidBrush(ForeColor)
hPrevBrush = SelectObject(hDC, hBlackBrush)
hPrevPen = SelectObject(hDC, GetStockObject(NULL_PEN))
For lIdx = 0 To UBound(uPoints)
With uPoints(lIdx)
.X = ModuleSize \ 2 + .X - 1
.Y = ModuleSize \ 2 + (lQrSize) * ModuleSize - .Y - 1
End With
Next
Call PolyPolygon(hDC, uPoints(0), aSizes(0), UBound(aSizes) + 1)
If hPrevBrush <> 0 Then
Call SelectObject(hDC, hPrevBrush)
hPrevBrush = 0
End If
If hPrevPen <> 0 Then
Call SelectObject(hDC, hPrevPen)
hPrevPen = 0
End If
With uDesc
.Size = LenB(uDesc)
.Type = vbPicTypeEMetafile
.hBmpOrIcon = CloseEnhMetaFile(hDC)
End With
If IID_IPicture(0) = 0 Then
IID_IPicture(0) = &H7BF80980: IID_IPicture(1) = &H101ABF32: IID_IPicture(2) = &HAA00BB8B: IID_IPicture(3) = &HAB0C3000
End If
hResult = OleCreatePictureIndirect(uDesc, IID_IPicture(0), 1, QRCodegenConvertToPicture)
If hResult < 0 Then
Err.Raise hResult, "OleCreatePictureIndirect"
End If
'--- not to destroy metafile, it's already owned by returned IPicture
hDC = 0
QH:
If hPrevBrush <> 0 Then
Call SelectObject(hDC, hPrevBrush)
hPrevBrush = 0
End If
If hPrevPen <> 0 Then
Call SelectObject(hDC, hPrevPen)
hPrevPen = 0
End If
If hDC <> 0 Then
Call CloseEnhMetaFile(hDC)
hDC = 0
End If
If hBlackBrush <> 0 Then
Call DeleteObject(hBlackBrush)
hBlackBrush = 0
End If
If IsArray(vErr) Then
On Error GoTo 0
Err.Raise vErr(0), vErr(1), vErr(2)
End If
Exit Function
EH:
vErr = Array(Err.Number, Err.Source, Err.Description)
Resume QH
End Function
Private Function QRCodegenGetSize(baQrCode() As Byte) As Long
If UBound(baQrCode) >= 0 Then
QRCodegenGetSize = baQrCode(0)
Debug.Assert VERSION_MIN * 4 + 17 <= QRCodegenGetSize And QRCodegenGetSize <= VERSION_MAX * 4 + 17
End If
End Function
Private Function QRCodegenGetModule(baQrCode() As Byte, ByVal lX As Long, ByVal lY As Long) As Boolean
Dim lQrSize As Long
If UBound(baQrCode) > 0 Then
lQrSize = baQrCode(0)
If 0 <= lX And lX < lQrSize And 0 <= lY And lY < lQrSize Then
QRCodegenGetModule = pvGetModuleBounded(baQrCode, lX, lY)
End If
End If
End Function
Private Function QRCodegenIsNumeric(sText As String) As Boolean
If LenB(sText) <> 0 Then
QRCodegenIsNumeric = Not (sText Like "*[!0-9]*")
End If
End Function
Private Function QRCodegenIsAlphanumeric(sText As String) As Boolean
Dim lIdx As Long
If LenB(sText) <> 0 Then
For lIdx = 1 To Len(sText)
If InStr(ALPHANUMERIC_CHARSET, Mid$(sText, lIdx, 1)) = 0 Then
Exit Function
End If
Next
End If
QRCodegenIsAlphanumeric = True
End Function
Private Function QRCodegenCalcSegmentBufferSize(ByVal eMode As QRCodegenMode, ByVal lNumChars As Long) As Long
Dim lSize As Long
lSize = pvCalcSegmentBitLength(eMode, lNumChars)
If lSize = -1 Then
QRCodegenCalcSegmentBufferSize = LONG_MAX
Else
Debug.Assert 0 <= lSize And lSize < INT16_MAX
QRCodegenCalcSegmentBufferSize = (lSize + 7) \ 8
End If
End Function
Private Function QRCodegenMakeBytes(baData() As Byte) As QRCodegenSegment
With QRCodegenMakeBytes
.Mode = QRCodegenMode_BYTE
.BitLength = pvCalcSegmentBitLength(.Mode, UBound(baData) + 1)
Debug.Assert .BitLength <> -1
.NumChars = UBound(baData) + 1
.Data = baData
End With
End Function
Private Function QRCodegenMakeNumeric(sDigits As String) As QRCodegenSegment
Dim lLen As Long
Dim lBitLen As Long
Dim lAccumData As Long
Dim lAccumCount As Long
Dim lIdx As Long
Dim lDigit As Long
With QRCodegenMakeNumeric
lLen = Len(sDigits)
.Mode = QRCodegenMode_NUMERIC
lBitLen = pvCalcSegmentBitLength(.Mode, lLen)
Debug.Assert lBitLen <> -1
ReDim .Data(0 To (lBitLen + 7) \ 8 - 1) As Byte
.NumChars = lLen
For lIdx = 1 To lLen
lDigit = Asc(Mid$(sDigits, lIdx, 1)) - 48 '--- Asc("0") = 48
Debug.Assert 0 <= lDigit And lDigit <= 9
lAccumData = lAccumData * 10 + lDigit
lAccumCount = lAccumCount + 1
If lAccumCount = 3 Then
pvAppendBitsToBuffer lAccumData, 10, .Data, .BitLength
lAccumData = 0
lAccumCount = 0
End If
Next
If lAccumCount > 0 Then
pvAppendBitsToBuffer lAccumData, lAccumCount * 3 + 1, .Data, .BitLength
End If
Debug.Assert lBitLen = .BitLength
End With
End Function
Private Function QRCodegenMakeAlphanumeric(sText As String) As QRCodegenSegment
Dim lLen As Long
Dim lBitLen As Long
Dim lAccumData As Long
Dim lAccumCount As Long
Dim lIdx As Long
Dim lChar As Long
With QRCodegenMakeAlphanumeric
lLen = Len(sText)
.Mode = QRCodegenMode_ALPHANUMERIC
lBitLen = pvCalcSegmentBitLength(.Mode, lLen)
Debug.Assert lBitLen <> -1
ReDim .Data(0 To (lBitLen + 7) \ 8 - 1) As Byte
.NumChars = lLen
For lIdx = 1 To lLen
lChar = InStr(ALPHANUMERIC_CHARSET, Mid$(sText, lIdx, 1)) - 1
Debug.Assert 0 <= lChar
lAccumData = lAccumData * 45 + lChar
lAccumCount = lAccumCount + 1
If lAccumCount = 2 Then
pvAppendBitsToBuffer lAccumData, 11, .Data, .BitLength
lAccumData = 0
lAccumCount = 0
End If
Next
If lAccumCount > 0 Then
pvAppendBitsToBuffer lAccumData, 6, .Data, .BitLength
End If
Debug.Assert lBitLen = .BitLength
End With
End Function
'= private ===============================================================
Private Sub pvInit()
Dim vSplit As Variant
Dim lIdx As Long
If ECC_CODEWORDS_PER_BLOCK(0, 0) <> 0 Then
Exit Sub
End If
LNG_POW2(0) = 1
For lIdx = 1 To UBound(LNG_POW2) - 1
LNG_POW2(lIdx) = LNG_POW2(lIdx - 1) * 2
Next
LNG_POW2(31) = &H80000000
vSplit = Split("-1| 7|10|15|20|26|18|20|24|30|18|20|24|26|30|22|24|28|30|28|28|28|28|30|30|26|28|30|30|30|30|30|30|30|30|30|30|30|30|30|30|" & _
"-1|10|16|26|18|24|16|18|22|22|26|30|22|22|24|24|28|28|26|26|26|26|28|28|28|28|28|28|28|28|28|28|28|28|28|28|28|28|28|28|28|" & _
"-1|13|22|18|26|18|24|18|22|20|24|28|26|24|20|30|24|28|28|26|30|28|30|30|30|30|28|30|30|30|30|30|30|30|30|30|30|30|30|30|30|" & _
"-1|17|28|22|16|22|28|26|26|24|28|24|28|22|24|24|30|28|28|26|28|30|24|30|30|30|30|30|30|30|30|30|30|30|30|30|30|30|30|30|30", "|")
For lIdx = 0 To UBound(vSplit)
ECC_CODEWORDS_PER_BLOCK(lIdx \ 41, lIdx Mod 41) = vSplit(lIdx)
Next
vSplit = Split("-1|1|1|1|1|1|2|2|2|2|4| 4| 4| 4| 4| 6| 6| 6| 6| 7| 8| 8| 9| 9|10|12|12|12|13|14|15|16|17|18|19|19|20|21|22|24|25|" & _
"-1|1|1|1|2|2|4|4|4|5|5| 5| 8| 9| 9|10|10|11|13|14|16|17|17|18|20|21|23|25|26|28|29|31|33|35|37|38|40|43|45|47|49|" & _
"-1|1|1|2|2|4|4|6|6|8|8| 8|10|12|16|12|17|16|18|21|20|23|23|25|27|29|34|34|35|38|40|43|45|48|51|53|56|59|62|65|68|" & _
"-1|1|1|2|4|4|4|5|6|8|8|11|11|16|16|18|16|19|21|25|25|25|34|30|32|35|37|40|42|45|48|51|54|57|60|63|66|70|74|77|81", "|")
For lIdx = 0 To UBound(vSplit)
NUM_ERROR_CORRECTION_BLOCKS(lIdx \ 41, lIdx Mod 41) = vSplit(lIdx)
Next
End Sub
Private Function pvGetNumDataCodewords(ByVal lVersion As Long, ByVal eEcl As QRCodegenEcc) As Long
Debug.Assert QRCodegenEcc_LOW <= eEcl And eEcl <= QRCodegenEcc_HIGH
pvGetNumDataCodewords = pvGetNumRawDataModules(lVersion) \ 8 - ECC_CODEWORDS_PER_BLOCK(eEcl, lVersion) * NUM_ERROR_CORRECTION_BLOCKS(eEcl, lVersion)
End Function
Private Function pvGetNumRawDataModules(ByVal lVersion As Long) As Long
Dim lNumAlign As Long
Debug.Assert VERSION_MIN <= lVersion And lVersion <= VERSION_MAX
pvGetNumRawDataModules = (16 * lVersion + 128) * lVersion + 64
If lVersion >= 2 Then
lNumAlign = lVersion \ 7 + 2
pvGetNumRawDataModules = pvGetNumRawDataModules - (25 * lNumAlign - 10) * lNumAlign + 55
If lVersion >= 7 Then
pvGetNumRawDataModules = pvGetNumRawDataModules - 36
End If
End If
Debug.Assert 208 <= pvGetNumRawDataModules And pvGetNumRawDataModules <= 29648
End Function
Private Function pvGetTotalBits(uSegments() As QRCodegenSegment, ByVal lVersion As Long) As Long
Dim lIdx As Long
Dim lCcBits As Long
For lIdx = 0 To UBound(uSegments)
lCcBits = pvNumCharCountBits(uSegments(lIdx).Mode, lVersion)
Debug.Assert 0 <= lCcBits And lCcBits <= 16
If uSegments(lIdx).NumChars >= LNG_POW2(lCcBits) Then
pvGetTotalBits = -1
GoTo QH
End If
pvGetTotalBits = pvGetTotalBits + 4 + lCcBits + uSegments(lIdx).BitLength
If pvGetTotalBits > INT16_MAX Then
pvGetTotalBits = -1
GoTo QH
End If
Next
Debug.Assert 0 <= pvGetTotalBits And pvGetTotalBits <= INT16_MAX
QH:
End Function
Private Function pvNumCharCountBits(ByVal eMode As QRCodegenMode, ByVal lVersion As Long) As Long
Dim lIdx As Long
lIdx = (lVersion + 7) \ 17 + 1
Select Case eMode
Case QRCodegenMode_NUMERIC
pvNumCharCountBits = Choose(lIdx, 10, 12, 14)
Case QRCodegenMode_ALPHANUMERIC
pvNumCharCountBits = Choose(lIdx, 9, 11, 13)
Case QRCodegenMode_BYTE
pvNumCharCountBits = Choose(lIdx, 8, 16, 16)
Case QRCodegenMode_KANJI
pvNumCharCountBits = Choose(lIdx, 0, 10, 12)
Case QRCodegenMode_ECI
pvNumCharCountBits = 0
Case Else
Debug.Assert False
End Select
End Function
Private Sub pvAddEccAndInterleave(baData() As Byte, ByVal lVersion As Long, ByVal eEcl As QRCodegenEcc, baResult() As Byte)
Dim lNumBlocks As Long
Dim lBlockEccLen As Long
Dim lRawCodewords As Long
Dim lDataLen As Long
Dim lNumShortBlocks As Long
Dim lShortBlockDataLen As Long
Dim baDiv() As Byte
Dim lIdx As Long
Dim lBlockPos As Long
Dim lBlockLen As Long
Dim baEcc() As Byte
Dim lJdx As Long
Dim lKdx As Long
Debug.Assert VERSION_MIN <= lVersion And lVersion <= VERSION_MAX
Debug.Assert QRCodegenEcc_LOW <= eEcl And eEcl <= QRCodegenEcc_HIGH
lNumBlocks = NUM_ERROR_CORRECTION_BLOCKS(eEcl, lVersion)
lBlockEccLen = ECC_CODEWORDS_PER_BLOCK(eEcl, lVersion)
lRawCodewords = pvGetNumRawDataModules(lVersion) \ 8
lDataLen = pvGetNumDataCodewords(lVersion, eEcl)
lNumShortBlocks = lNumBlocks - lRawCodewords Mod lNumBlocks
lShortBlockDataLen = lRawCodewords \ lNumBlocks - lBlockEccLen
ReDim baResult(0 To lDataLen + lBlockEccLen * lNumBlocks - 1) As Byte
pvReedSolomonComputeDivisor lBlockEccLen, baDiv
For lIdx = 0 To lNumBlocks - 1
lBlockLen = lShortBlockDataLen + IIf(lIdx < lNumShortBlocks, 0, 1)
pvReedSolomonComputeRemainder baData, lBlockPos, lBlockLen, baDiv, lBlockEccLen, baEcc
lKdx = lIdx
For lJdx = 0 To lBlockLen - 1
If lJdx = lShortBlockDataLen Then
lKdx = lKdx - lNumShortBlocks
End If
baResult(lKdx) = baData(lBlockPos + lJdx)
lKdx = lKdx + lNumBlocks
Next
lKdx = lDataLen + lIdx
For lJdx = 0 To lBlockEccLen - 1
baResult(lKdx) = baEcc(lJdx)
lKdx = lKdx + lNumBlocks
Next
lBlockPos = lBlockPos + lBlockLen
Next
End Sub
Private Sub pvReedSolomonComputeDivisor(ByVal lDegree As Long, baResult() As Byte)
Dim lRoot As Long
Dim lIdx As Long
Dim lJdx As Long
ReDim baResult(0 To lDegree - 1) As Byte
baResult(lDegree - 1) = 1
lRoot = 1
For lIdx = 0 To lDegree - 1
For lJdx = 0 To lDegree - 1
baResult(lJdx) = pvReedSolomonMultiply(baResult(lJdx), lRoot)
If lJdx + 1 < lDegree Then
baResult(lJdx) = baResult(lJdx) Xor baResult(lJdx + 1)
End If
Next
lRoot = pvReedSolomonMultiply(lRoot, 2)
Next
End Sub
Private Sub pvReedSolomonComputeRemainder( _
baData() As Byte, ByVal lDataPos As Long, ByVal lDataSize As Long, _
baGen() As Byte, ByVal lDegree As Long, baResult() As Byte)
Dim lIdx As Long
Dim lJdx As Long
Dim bFactor As Byte
ReDim baResult(0 To lDegree - 1) As Byte
For lIdx = lDataPos To lDataPos + lDataSize - 1
bFactor = baData(lIdx) Xor baResult(0)
For lJdx = 0 To lDegree - 2
baResult(lJdx) = baResult(lJdx + 1) Xor pvReedSolomonMultiply(baGen(lJdx), bFactor)
Next
baResult(lDegree - 1) = pvReedSolomonMultiply(baGen(lJdx), bFactor)
Next
End Sub
Private Function pvReedSolomonMultiply(ByVal bX As Byte, ByVal bY As Byte) As Byte
Dim lIdx As Long
Dim lTemp As Long
For lIdx = 7 To 0 Step -1
If (pvReedSolomonMultiply And &H80) <> 0 Then
lTemp = &H11D
Else
lTemp = 0
End If
pvReedSolomonMultiply = ((pvReedSolomonMultiply * 2) Xor lTemp) And &HFF
If (bY And LNG_POW2(lIdx)) <> 0 Then
pvReedSolomonMultiply = pvReedSolomonMultiply Xor bX
End If
Next
End Function
Private Sub pvInitializeFunctionModules(ByVal lVersion As Long, baQrCode() As Byte)
Dim lQrSize As Long
Dim lNumAlign As Long
Dim baAlignPatPos(0 To 6) As Byte
Dim lIdx As Long
Dim lJdx As Long
lQrSize = lVersion * 4 + 17
ReDim baQrCode(0 To (lQrSize * lQrSize + 7) \ 8) As Byte
baQrCode(0) = lQrSize
'--- Fill horizontal and vertical timing patterns
pvFillRectangle 6, 0, 1, lQrSize, baQrCode
pvFillRectangle 0, 6, lQrSize, 1, baQrCode
'--- Fill 3 finder patterns (all corners except bottom right) and format bits
pvFillRectangle 0, 0, 9, 9, baQrCode
pvFillRectangle lQrSize - 8, 0, 8, 9, baQrCode
pvFillRectangle 0, lQrSize - 8, 9, 8, baQrCode
'--- Fill numerous alignment patterns
lNumAlign = pvGetAlignmentPatternPositions(lVersion, baAlignPatPos)
For lIdx = 0 To lNumAlign - 1
For lJdx = 0 To lNumAlign - 1
If (lIdx = 0 And lJdx = 0) Or (lIdx = 0 And lJdx = lNumAlign - 1) Or (lIdx = lNumAlign - 1 And lJdx = 0) Then
'--- Don't draw on the three finder corners
Else
pvFillRectangle baAlignPatPos(lIdx) - 2, baAlignPatPos(lJdx) - 2, 5, 5, baQrCode
End If
Next
Next
'--- Fill version blocks
If lVersion >= 7 Then
pvFillRectangle lQrSize - 11, 0, 3, 6, baQrCode
pvFillRectangle 0, lQrSize - 11, 6, 3, baQrCode
End If
End Sub
Private Sub pvDrawLightFunctionModules(ByVal lVersion As Long, baQrCode() As Byte)
Dim lQrSize As Long
Dim lIdx As Long
Dim lJdx As Long
Dim lKdx As Long
Dim lDy As Long
Dim lDx As Long
Dim lDist As Long
Dim lNumAlign As Long
Dim baAlignPatPos(0 To 6) As Byte
Dim bIsDark As Boolean
Dim lRem As Long
Dim lBits As Long
lQrSize = baQrCode(0)
'--- Draw horizontal and vertical timing patterns
For lIdx = 7 To lQrSize - 7 Step 2
pvSetModuleBounded baQrCode, 6, lIdx, False
pvSetModuleBounded baQrCode, lIdx, 6, False
Next
'--- Draw 3 finder patterns (all corners except bottom right; overwrites some timing modules)
For lDy = -4 To 4
For lDx = -4 To 4
lDist = Abs(lDx)
If Abs(lDy) > lDist Then
lDist = Abs(lDy)
End If
If lDist = 2 Or lDist = 4 Then
pvSetModuleUnbounded baQrCode, 3 + lDx, 3 + lDy, False
pvSetModuleUnbounded baQrCode, lQrSize - 4 + lDx, 3 + lDy, False
pvSetModuleUnbounded baQrCode, 3 + lDx, lQrSize - 4 + lDy, False
End If
Next
Next
'--- Draw numerous alignment patterns
lNumAlign = pvGetAlignmentPatternPositions(lVersion, baAlignPatPos)
For lIdx = 0 To lNumAlign - 1
For lJdx = 0 To lNumAlign - 1
If (lIdx = 0 And lJdx = 0) Or (lIdx = 0 And lJdx = lNumAlign - 1) Or (lIdx = lNumAlign - 1 And lJdx = 0) Then
'--- Don't draw on the three finder corners
Else
For lDy = -1 To 1
For lDx = -1 To 1
bIsDark = (lDx = 0 And lDy = 0)
pvSetModuleBounded baQrCode, baAlignPatPos(lIdx) + lDx, baAlignPatPos(lJdx) + lDy, bIsDark
Next
Next
End If
Next
Next
'--- Draw version blocks
If lVersion >= 7 Then
'--- Calculate error correction code and pack bits
lRem = lVersion
For lIdx = 0 To 11
lRem = (lRem * 2) Xor ((lRem \ LNG_POW2(11)) * &H1F25)
Next
lBits = lVersion * LNG_POW2(12) Or lRem
Debug.Assert lBits < LNG_POW2(18)
'--- Draw two copies
For lIdx = 0 To 5
For lJdx = 0 To 2
lKdx = lQrSize - 11 + lJdx
bIsDark = ((lBits And 1) <> 0)
pvSetModuleBounded baQrCode, lKdx, lIdx, bIsDark
pvSetModuleBounded baQrCode, lIdx, lKdx, bIsDark
lBits = lBits \ 2
Next
Next
End If
End Sub
Private Sub pvDrawFormatBits(ByVal eEcl As QRCodegenEcc, ByVal eMask As QRCodegenMask, baQrCode() As Byte)
Dim lData As Long
Dim lRem As Long
Dim lBits As Long
Dim lIdx As Long
Dim lQrSize As Long
'--- Calculate error correction code and pack bits
lData = Choose(eEcl + 1, 1, 0, 3, 2) * 8 Or eMask
lRem = lData
For lIdx = 0 To 9
lRem = (lRem * 2) Xor ((lRem \ LNG_POW2(9)) * &H537)
Next
lBits = (lData * LNG_POW2(10) Or lRem) Xor &H5412
'--- Draw first copy
For lIdx = 0 To 5
pvSetModuleBounded baQrCode, 8, lIdx, pvGetBit(lBits, lIdx)
Next
pvSetModuleBounded baQrCode, 8, 7, pvGetBit(lBits, 6)
pvSetModuleBounded baQrCode, 8, 8, pvGetBit(lBits, 7)
pvSetModuleBounded baQrCode, 7, 8, pvGetBit(lBits, 8)
For lIdx = 9 To 14
pvSetModuleBounded baQrCode, 14 - lIdx, 8, pvGetBit(lBits, lIdx)
Next
'--- Draw second copy
lQrSize = baQrCode(0)
For lIdx = 0 To 7
pvSetModuleBounded baQrCode, lQrSize - 1 - lIdx, 8, pvGetBit(lBits, lIdx)
Next
For lIdx = 8 To 14
pvSetModuleBounded baQrCode, 8, lQrSize - 15 + lIdx, pvGetBit(lBits, lIdx)
Next
pvSetModuleBounded baQrCode, 8, lQrSize - 8, True
End Sub
Private Function pvGetAlignmentPatternPositions(ByVal lVersion As Long, baResult() As Byte) As Long
Dim lNumAlign As Long
Dim lStep As Long
Dim lIdx As Long
Dim lPos As Long
If lVersion > 1 Then
lNumAlign = lVersion \ 7 + 2
lStep = IIf(lVersion = 32, 26, ((lVersion * 4 + lNumAlign * 2 + 1) \ (lNumAlign * 2 - 2)) * 2)
lPos = lVersion * 4 + 10
For lIdx = lNumAlign - 1 To 1 Step -1
baResult(lIdx) = lPos
lPos = lPos - lStep
Next
baResult(0) = 6
pvGetAlignmentPatternPositions = lNumAlign
End If
End Function
Private Sub pvFillRectangle(ByVal lLeft As Long, ByVal lTop As Long, ByVal lWidth As Long, ByVal lHeight As Long, baQrCode() As Byte)
Dim lDy As Long
Dim lDx As Long
For lDy = 0 To lHeight - 1
For lDx = 0 To lWidth - 1
pvSetModuleBounded baQrCode, lLeft + lDx, lTop + lDy, True
Next
Next
End Sub
Private Sub pvDrawCodewords(baData() As Byte, baQrCode() As Byte)
Dim lQrSize As Long
Dim lBitLen As Long
Dim lIdx As Long
Dim lRight As Long
Dim lVert As Long
Dim lJdx As Long
Dim lX As Long
Dim lY As Long
Dim bIsDark As Boolean
lQrSize = baQrCode(0)
lBitLen = (UBound(baData) + 1) * 8
For lRight = lQrSize - 1 To 1 Step -2
If lRight = 6 Then
lRight = 5
End If
For lVert = 0 To lQrSize - 1
For lJdx = 0 To 1
lX = lRight - lJdx
If ((lRight + 1) And 2) = 0 Then
lY = lQrSize - 1 - lVert
Else
lY = lVert
End If
If Not pvGetModuleBounded(baQrCode, lX, lY) And lIdx < lBitLen Then
bIsDark = pvGetBit(baData(lIdx \ 8), 7 - (lIdx And 7))
pvSetModuleBounded baQrCode, lX, lY, bIsDark
lIdx = lIdx + 1
End If
Next
Next
Next
Debug.Assert lIdx = lBitLen
End Sub
Private Sub pvApplyMask(baFunctionModules() As Byte, baQrCode() As Byte, ByVal eMask As QRCodegenMask)
Dim lQrSize As Long
Dim lX As Long
Dim lY As Long
Dim bInvert As Boolean
Dim bVal As Boolean
Debug.Assert QRCodegenMask_0 <= eMask And eMask <= QRCodegenMask_7
lQrSize = baQrCode(0)
For lY = 0 To lQrSize - 1
For lX = 0 To lQrSize - 1
If Not pvGetModuleBounded(baFunctionModules, lX, lY) Then
Select Case eMask
Case QRCodegenMask_0
bInvert = (lX + lY) Mod 2 = 0
Case QRCodegenMask_1
bInvert = lY Mod 2 = 0
Case QRCodegenMask_2
bInvert = lX Mod 3 = 0
Case QRCodegenMask_3
bInvert = (lX + lY) Mod 3 = 0
Case QRCodegenMask_4
bInvert = (lX \ 3 + lY \ 2) Mod 2 = 0
Case QRCodegenMask_5
bInvert = (lX * lY Mod 2 + lX * lY Mod 3) = 0
Case QRCodegenMask_6
bInvert = (lX * lY Mod 2 + lX * lY Mod 3) Mod 2 = 0
Case QRCodegenMask_7
bInvert = ((lX + lY) Mod 2 + lX * lY Mod 3) Mod 2 = 0
End Select
bVal = pvGetModuleBounded(baQrCode, lX, lY)
pvSetModuleBounded baQrCode, lX, lY, (bVal Xor bInvert)
End If
Next
Next
End Sub
Private Function pvGetPenaltyScore(baQrCode() As Byte) As Long
Dim lQrSize As Long
Dim lX As Long
Dim lY As Long
Dim bRunColor As Boolean
Dim lRunX As Long
Dim lRunY As Long
Dim aRunHistory() As Long
Dim lDark As Long
Dim lTotal As Long
Dim lKdx As Long
lQrSize = baQrCode(0)
'--- Adjacent modules in row having same color, and finder-like patterns
For lY = 0 To lQrSize - 1
bRunColor = False
lRunX = 0
ReDim aRunHistory(0 To 6) As Long
For lX = 0 To lQrSize - 1
If pvGetModuleBounded(baQrCode, lX, lY) = bRunColor Then
lRunX = lRunX + 1
If lRunX = 5 Then
pvGetPenaltyScore = pvGetPenaltyScore + PENALTY_N1
ElseIf lRunX > 5 Then
pvGetPenaltyScore = pvGetPenaltyScore + 1
End If
Else
pvFinderPenaltyAddHistory lRunX, aRunHistory, lQrSize
If Not bRunColor Then
pvGetPenaltyScore = pvGetPenaltyScore + pvFinderPenaltyCountPatterns(aRunHistory, lQrSize) * PENALTY_N3
End If
bRunColor = pvGetModuleBounded(baQrCode, lX, lY)
lRunX = 1
End If
Next
pvGetPenaltyScore = pvGetPenaltyScore + pvFinderPenaltyTerminateAndCount(bRunColor, lRunX, aRunHistory, lQrSize) * PENALTY_N3
Next
'--- Adjacent modules in column having same color, and finder-like patterns
For lX = 0 To lQrSize - 1
bRunColor = False
lRunY = 0
ReDim aRunHistory(0 To 6) As Long
For lY = 0 To lQrSize - 1
If pvGetModuleBounded(baQrCode, lX, lY) = bRunColor Then
lRunY = lRunY + 1
If lRunY = 5 Then
pvGetPenaltyScore = pvGetPenaltyScore + PENALTY_N1
ElseIf lRunY > 5 Then
pvGetPenaltyScore = pvGetPenaltyScore + 1
End If
Else
pvFinderPenaltyAddHistory lRunY, aRunHistory, lQrSize
If Not bRunColor Then
pvGetPenaltyScore = pvGetPenaltyScore + pvFinderPenaltyCountPatterns(aRunHistory, lQrSize) * PENALTY_N3
End If
bRunColor = pvGetModuleBounded(baQrCode, lX, lY)
lRunY = 1
End If
Next
pvGetPenaltyScore = pvGetPenaltyScore + pvFinderPenaltyTerminateAndCount(bRunColor, lRunY, aRunHistory, lQrSize) * PENALTY_N3
Next
'--- 2*2 blocks of modules having same color
For lY = 0 To lQrSize - 2
For lX = 0 To lQrSize - 2
bRunColor = pvGetModuleBounded(baQrCode, lX, lY)
If bRunColor = pvGetModuleBounded(baQrCode, lX + 1, lY) And _
bRunColor = pvGetModuleBounded(baQrCode, lX, lY + 1) And _
bRunColor = pvGetModuleBounded(baQrCode, lX + 1, lY + 1) Then
pvGetPenaltyScore = pvGetPenaltyScore + PENALTY_N2
End If
Next
Next
'--- Balance of dark and light modules
For lY = 0 To lQrSize - 1
For lX = 0 To lQrSize - 1
If pvGetModuleBounded(baQrCode, lX, lY) Then
lDark = lDark + 1
End If
Next
Next
lTotal = lQrSize * lQrSize
'--- Compute the smallest integer k >= 0 such that (45-5k)% <= dark/total <= (55+5k)%
lKdx = ((Abs(lDark * 20 - lTotal * 10) + lTotal - 1) \ lTotal) - 1
Debug.Assert 0 <= lKdx And lKdx <= 9
pvGetPenaltyScore = pvGetPenaltyScore + lKdx * PENALTY_N4
Debug.Assert 0 <= pvGetPenaltyScore And pvGetPenaltyScore <= 2568888
End Function
Private Function pvFinderPenaltyCountPatterns(aRunHistory() As Long, ByVal lQrSize As Long) As Long
Dim lN As Long
Dim bCore As Boolean
lN = aRunHistory(1)
Debug.Assert lN <= lQrSize * 3
bCore = (lN > 0 And aRunHistory(2) = lN And aRunHistory(3) = lN * 3 And aRunHistory(4) = lN And aRunHistory(5) = lN)
'-- The maximum QR Code size is 177, hence the dark run length n <= 177.
pvFinderPenaltyCountPatterns = IIf(bCore And aRunHistory(0) >= lN * 4 And aRunHistory(6) >= lN, 1, 0) _
+ IIf(bCore And aRunHistory(6) >= lN * 4 And aRunHistory(0) >= lN, 1, 0)
End Function
Private Function pvFinderPenaltyTerminateAndCount(ByVal bCurrentRunColor As Boolean, ByVal lCurrentRunLength As Long, aRunHistory() As Long, ByVal lQrSize As Long) As Long
If bCurrentRunColor Then
pvFinderPenaltyAddHistory lCurrentRunLength, aRunHistory, lQrSize
lCurrentRunLength = 0
End If
lCurrentRunLength = lCurrentRunLength + lQrSize
pvFinderPenaltyAddHistory lCurrentRunLength, aRunHistory, lQrSize
pvFinderPenaltyTerminateAndCount = pvFinderPenaltyCountPatterns(aRunHistory, lQrSize)
End Function
Private Function pvFinderPenaltyAddHistory(ByVal lCurrentRunLength As Long, aRunHistory() As Long, ByVal lQrSize As Long) As Long
If aRunHistory(0) = 0 Then
lCurrentRunLength = lCurrentRunLength + lQrSize
End If
Debug.Assert UBound(aRunHistory) + 1 = 7
aRunHistory(6) = aRunHistory(5)
aRunHistory(5) = aRunHistory(4)
aRunHistory(4) = aRunHistory(3)
aRunHistory(3) = aRunHistory(2)
aRunHistory(2) = aRunHistory(1)
aRunHistory(1) = aRunHistory(0)
aRunHistory(0) = lCurrentRunLength
End Function
Private Function pvGetModuleBounded(baQrCode() As Byte, ByVal lX As Long, ByVal lY As Long) As Boolean
Dim lQrSize As Long
Dim lIndex As Long
lQrSize = baQrCode(0)
Debug.Assert 21 <= lQrSize And lQrSize <= 177 And 0 <= lX And lX < lQrSize And 0 <= lY And lY < lQrSize
lIndex = lY * lQrSize + lX
pvGetModuleBounded = pvGetBit(baQrCode(lIndex \ 8 + 1), lIndex And 7)
End Function
Private Function pvSetModuleBounded(baQrCode() As Byte, ByVal lX As Long, ByVal lY As Long, ByVal bIsDark As Boolean) As Long
Dim lQrSize As Long
Dim lIndex As Long
Dim lByteIndex As Long
lQrSize = baQrCode(0)
Debug.Assert 21 <= lQrSize And lQrSize <= 177 And 0 <= lX And lX < lQrSize And 0 <= lY And lY < lQrSize
lIndex = lY * lQrSize + lX
lByteIndex = lIndex \ 8 + 1
If bIsDark Then
baQrCode(lByteIndex) = baQrCode(lByteIndex) Or LNG_POW2(lIndex And 7)
Else
baQrCode(lByteIndex) = baQrCode(lByteIndex) And Not LNG_POW2(lIndex And 7)
End If
End Function
Private Function pvSetModuleUnbounded(baQrCode() As Byte, ByVal lX As Long, ByVal lY As Long, ByVal bIsDark As Boolean) As Long
Dim lQrSize As Long
lQrSize = baQrCode(0)
If 0 <= lX And lX < lQrSize And 0 <= lY And lY < lQrSize Then
pvSetModuleBounded baQrCode, lX, lY, bIsDark
End If
End Function
Private Function pvGetBit(ByVal lX As Long, ByVal lIdx As Long) As Boolean
pvGetBit = (lX And LNG_POW2(lIdx)) <> 0
End Function
Private Function pvCalcSegmentBitLength(ByVal eMode As QRCodegenMode, ByVal lNumChars As Long) As Long
If lNumChars > INT16_MAX Then
pvCalcSegmentBitLength = -1
Else
pvCalcSegmentBitLength = lNumChars
Select Case eMode
Case QRCodegenMode_NUMERIC
pvCalcSegmentBitLength = (pvCalcSegmentBitLength * 10 + 2) \ 3
Case QRCodegenMode_ALPHANUMERIC
pvCalcSegmentBitLength = (pvCalcSegmentBitLength * 11 + 1) \ 2
Case QRCodegenMode_BYTE
pvCalcSegmentBitLength = pvCalcSegmentBitLength * 8
Case QRCodegenMode_KANJI
pvCalcSegmentBitLength = pvCalcSegmentBitLength * 13
Case QRCodegenMode_ECI
Debug.Assert lNumChars = 0
pvCalcSegmentBitLength = 3 * 8
End Select
If pvCalcSegmentBitLength > INT16_MAX Then
pvCalcSegmentBitLength = -1
End If
End If
End Function
Private Function pvGetBufferLenForVersion(ByVal lVersion As Long) As Long
pvGetBufferLenForVersion = (((lVersion * 4 + 17) * (lVersion * 4 + 17) + 7) \ 8 + 1)
End Function
Private Sub pvAppendBitsToBuffer(ByVal lVal As Long, ByVal lNumBits As Long, baBuffer() As Byte, lBitLen As Long)
Dim lIdx As Long
Debug.Assert 0 <= lNumBits And lNumBits <= 16
For lIdx = lNumBits - 1 To 0 Step -1
If (lVal And LNG_POW2(lIdx)) <> 0 Then
baBuffer(lBitLen \ 8) = baBuffer(lBitLen \ 8) Or LNG_POW2(7 - (lBitLen And 7))
End If
lBitLen = lBitLen + 1
Next
End Sub
Private Function pvToUtf8Array(sText As String) As Byte()
Const CP_UTF8 As Long = 65001
Dim baRetVal() As Byte
Dim lSize As Long
lSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), ByVal 0, 0, 0, 0)
If lSize > 0 Then
ReDim baRetVal(0 To lSize - 1) As Byte
Call WideCharToMultiByte(CP_UTF8, 0, StrPtr(sText), Len(sText), baRetVal(0), lSize, 0, 0)
Else
baRetVal = vbNullString
End If
pvToUtf8Array = baRetVal
End Function
Private Function DispCallByVtbl(pUnk As stdole.IUnknown, ByVal lIndex As Long, ParamArray A() As Variant) As Variant
Const CC_STDCALL As Long = 4
#If Win64 Then
Const PTR_SIZE As Long = 8
#Else
Const PTR_SIZE As Long = 4
#End If
Dim lIdx As Long
Dim vParam() As Variant
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As LongPtr
Dim hResult As Long
vParam = A
For lIdx = 0 To UBound(vParam)
vType(lIdx) = VarType(vParam(lIdx))
vPtr(lIdx) = VarPtr(vParam(lIdx))
Next
hResult = DispCallFunc(ObjPtr(pUnk), lIndex * PTR_SIZE, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByVtbl)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function
Private Sub pvConstructVectors(baQrCode() As Byte, ByVal SquareModules As Boolean, uVectors() As RECT)
Dim lQrSize As Long
Dim lX As Long
Dim lY As Long
Dim lHasLeft As Long
Dim lHasUp As Long
Dim lHasRight As Long
Dim lHasDown As Long
Dim bHasDiag As Boolean
lQrSize = QRCodegenGetSize(baQrCode)
'--- oversize array by one element in all 4 directions
ReDim uVectors(-1 To lQrSize + 1, -1 To lQrSize + 1) As RECT
For lY = 0 To lQrSize
For lX = 0 To lQrSize
If QRCodegenGetModule(baQrCode, lX, lY) And Not QRCodegenGetModule(baQrCode, lX, lY - 1) Then
uVectors(lX, lY).Right = LINE_TO
End If
If QRCodegenGetModule(baQrCode, lX - 1, lY) And Not QRCodegenGetModule(baQrCode, lX, lY) Then
uVectors(lX, lY).Bottom = LINE_TO
End If
If QRCodegenGetModule(baQrCode, lX - 1, lY - 1) And Not QRCodegenGetModule(baQrCode, lX - 1, lY) Then
uVectors(lX, lY).Left = LINE_TO
End If
If QRCodegenGetModule(baQrCode, lX, lY - 1) And Not QRCodegenGetModule(baQrCode, lX - 1, lY - 1) Then
uVectors(lX, lY).Top = LINE_TO
End If
Next
Next
If SquareModules Then
Exit Sub
End If
'--- mark curving vectors
For lY = 0 To lQrSize - 1
For lX = 0 To lQrSize - 1
lHasLeft = -QRCodegenGetModule(baQrCode, lX - 1, lY)
lHasUp = -QRCodegenGetModule(baQrCode, lX, lY - 1)
lHasRight = -QRCodegenGetModule(baQrCode, lX + 1, lY)
lHasDown = -QRCodegenGetModule(baQrCode, lX, lY + 1)
If lHasLeft + lHasUp + lHasRight + lHasDown < 3 Then
If QRCodegenGetModule(baQrCode, lX, lY) Then
If lHasLeft = 0 And lHasUp = 0 Then
uVectors(lX, lY + 1).Top = TURN_RIGHT
End If
If lHasRight = 0 And lHasUp = 0 Then
uVectors(lX, lY).Right = TURN_RIGHT
End If
If lHasRight = 0 And lHasDown = 0 Then
uVectors(lX + 1, lY).Bottom = TURN_RIGHT
End If
If lHasLeft = 0 And lHasDown = 0 Then
uVectors(lX + 1, lY + 1).Left = TURN_RIGHT
End If
Else
If QRCodegenGetModule(baQrCode, lX - 1, lY - 1) And lHasLeft > 0 And lHasUp > 0 Then
uVectors(lX + 1, lY).Left = TURN_LEFT
End If
If QRCodegenGetModule(baQrCode, lX + 1, lY - 1) And lHasRight > 0 And lHasUp > 0 Then
uVectors(lX + 1, lY + 1).Top = TURN_LEFT
End If
If QRCodegenGetModule(baQrCode, lX - 1, lY + 1) And lHasLeft > 0 And lHasDown > 0 Then
uVectors(lX, lY).Bottom = TURN_LEFT
End If
If QRCodegenGetModule(baQrCode, lX + 1, lY + 1) And lHasRight > 0 And lHasDown > 0 Then
uVectors(lX, lY + 1).Right = TURN_LEFT
End If
End If
End If
Next
Next
'--- mark wide and super-wide curves
For lY = 0 To lQrSize - 1
For lX = 0 To lQrSize - 1
If QRCodegenGetModule(baQrCode, lX, lY) Then
lHasLeft = -QRCodegenGetModule(baQrCode, lX - 1, lY)
If lHasLeft <> 0 Then
lHasLeft = lHasLeft + -QRCodegenGetModule(baQrCode, lX - 2, lY)
End If
lHasUp = -QRCodegenGetModule(baQrCode, lX, lY - 1)
If lHasUp <> 0 Then
lHasUp = lHasUp + -QRCodegenGetModule(baQrCode, lX, lY - 2)
End If
lHasRight = -QRCodegenGetModule(baQrCode, lX + 1, lY)
If lHasRight <> 0 Then
lHasRight = lHasRight + -QRCodegenGetModule(baQrCode, lX + 2, lY)
End If
lHasDown = -QRCodegenGetModule(baQrCode, lX, lY + 1)
If lHasDown <> 0 Then
lHasDown = lHasDown + -QRCodegenGetModule(baQrCode, lX, lY + 2)
End If
bHasDiag = QRCodegenGetModule(baQrCode, lX - 1, lY - 1) Or QRCodegenGetModule(baQrCode, lX - 1, lY + 1) _
Or QRCodegenGetModule(baQrCode, lX + 1, lY - 1) Or QRCodegenGetModule(baQrCode, lX + 1, lY + 1)
If Not bHasDiag And lHasLeft = 0 And lHasUp = 0 And lHasRight > 0 And lHasDown > 0 Then
If uVectors(lX + 2, lY + 1).Left = TURN_LEFT And lHasRight > 1 And lHasDown > 1 Then
uVectors(lX, lY + 1).Top = SKIP_TO
uVectors(lX, lY + 2).Top = SUPERWIDE_RIGHT
uVectors(lX + 2, lY + 1).Left = WIDE_LEFT
Else
uVectors(lX, lY + 1).Top = WIDE_RIGHT
End If
ElseIf Not bHasDiag And lHasLeft > 0 And lHasUp = 0 And lHasRight = 0 And lHasDown > 0 Then
If uVectors(lX, lY + 2).Top = TURN_LEFT And lHasLeft > 1 And lHasDown > 1 Then
uVectors(lX, lY).Right = SKIP_TO
uVectors(lX - 1, lY).Right = SUPERWIDE_RIGHT
uVectors(lX, lY + 2).Top = WIDE_LEFT
Else
uVectors(lX, lY).Right = WIDE_RIGHT
End If
ElseIf Not bHasDiag And lHasLeft > 0 And lHasUp > 0 And lHasRight = 0 And lHasDown = 0 Then
If uVectors(lX - 1, lY).Right = TURN_LEFT And lHasLeft > 1 And lHasUp > 1 Then
uVectors(lX + 1, lY).Bottom = SKIP_TO
uVectors(lX + 1, lY - 1).Bottom = SUPERWIDE_RIGHT
uVectors(lX - 1, lY).Right = WIDE_LEFT
Else
uVectors(lX + 1, lY).Bottom = WIDE_RIGHT
End If
ElseIf Not bHasDiag And lHasLeft = 0 And lHasUp > 0 And lHasRight > 0 And lHasDown = 0 Then
If uVectors(lX + 1, lY - 1).Bottom = TURN_LEFT And lHasUp > 1 And lHasRight > 1 Then
uVectors(lX + 1, lY + 1).Left = SKIP_TO
uVectors(lX + 2, lY + 1).Left = SUPERWIDE_RIGHT
uVectors(lX + 1, lY - 1).Bottom = WIDE_LEFT
Else
uVectors(lX + 1, lY + 1).Left = WIDE_RIGHT
End If
End If
End If
Next
Next
End Sub
Private Sub pvConstructPolygons(uVectors() As RECT, ByVal ModuleSize As Long, uPoints() As POINTAPI, aSizes() As Long)
Const TURN_STEPS As Long = 4
Const WIDE_STEPS As Long = 2 * TURN_STEPS
Const SUPERWIDE_STEPS As Long = 3 * TURN_STEPS
Dim lX As Long
Dim lY As Long
Dim lNumPolys As Long
Dim lPos As Long
Dim lSize As Long
Dim lValue As Long
ReDim uPoints(0 To 8) As POINTAPI
ReDim aSizes(0 To 8) As Long
Do While pvFindStartVector(uVectors, lX, lY)
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize
Do
With uVectors(lX, lY)
If .Right <> 0 Then
lValue = .Right
.Right = 0
Select Case lValue
Case TURN_LEFT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize + ModuleSize \ 2, lY * ModuleSize
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize, lY * ModuleSize - ModuleSize \ 2, TURN_STEPS
Case TURN_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize + ModuleSize \ 2, lY * ModuleSize
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize, lY * ModuleSize + ModuleSize \ 2, TURN_STEPS
Case WIDE_LEFT
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize, lY * ModuleSize - ModuleSize, WIDE_STEPS
Case WIDE_RIGHT
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize, lY * ModuleSize + ModuleSize, WIDE_STEPS
Case SUPERWIDE_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize + ModuleSize \ 2, lY * ModuleSize
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize + 2 * ModuleSize, lY * ModuleSize + ModuleSize * 3 \ 2, SUPERWIDE_STEPS
End Select
lX = lX + 1
ElseIf .Bottom <> 0 Then
lValue = .Bottom
.Bottom = 0
Select Case lValue
Case TURN_LEFT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize + ModuleSize \ 2
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize \ 2, lY * ModuleSize + ModuleSize, TURN_STEPS
Case TURN_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize + ModuleSize \ 2
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize \ 2, lY * ModuleSize + ModuleSize, TURN_STEPS
Case WIDE_LEFT
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize, lY * ModuleSize + ModuleSize, WIDE_STEPS
Case WIDE_RIGHT
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize, lY * ModuleSize + ModuleSize, WIDE_STEPS
Case SUPERWIDE_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize + ModuleSize \ 2
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize * 3 \ 2, lY * ModuleSize + 2 * ModuleSize, SUPERWIDE_STEPS
End Select
lY = lY + 1
ElseIf .Left <> 0 Then
lValue = .Left
.Left = 0
Select Case lValue
Case TURN_LEFT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize - ModuleSize \ 2, lY * ModuleSize
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize, lY * ModuleSize + ModuleSize \ 2, TURN_STEPS
Case TURN_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize - ModuleSize \ 2, lY * ModuleSize
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize, lY * ModuleSize - ModuleSize \ 2, TURN_STEPS
Case WIDE_LEFT
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize, lY * ModuleSize + ModuleSize, WIDE_STEPS
Case WIDE_RIGHT
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize, lY * ModuleSize - ModuleSize, WIDE_STEPS
Case SUPERWIDE_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize - ModuleSize \ 2, lY * ModuleSize
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize - 2 * ModuleSize, lY * ModuleSize - ModuleSize * 3 \ 2, SUPERWIDE_STEPS
End Select
lX = lX - 1
ElseIf .Top <> 0 Then
lValue = .Top
.Top = 0
Select Case lValue
Case TURN_LEFT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize - ModuleSize \ 2
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize \ 2, lY * ModuleSize - ModuleSize, TURN_STEPS
Case TURN_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize - ModuleSize \ 2
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize \ 2, lY * ModuleSize - ModuleSize, TURN_STEPS
Case WIDE_LEFT
pvAppendLeftTurn uPoints, lPos, lSize, lX * ModuleSize - ModuleSize, lY * ModuleSize - ModuleSize, WIDE_STEPS
Case WIDE_RIGHT
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize, lY * ModuleSize - ModuleSize, WIDE_STEPS
Case SUPERWIDE_RIGHT
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize - ModuleSize \ 2
pvAppendRightTurn uPoints, lPos, lSize, lX * ModuleSize + ModuleSize * 3 \ 2, lY * ModuleSize - 2 * ModuleSize, SUPERWIDE_STEPS
End Select
lY = lY - 1
Else
lValue = -1
End If
End With
If lValue < 0 Then
Exit Do
ElseIf lValue = LINE_TO Then
pvAppendLineTo uPoints, lPos, lSize, lX * ModuleSize, lY * ModuleSize
End If
Loop
If UBound(aSizes) < lNumPolys Then
ReDim Preserve aSizes(0 To 2 * UBound(aSizes)) As Long
End If
aSizes(lNumPolys) = lSize
lNumPolys = lNumPolys + 1
lPos = lPos + lSize
lSize = 0
Loop
ReDim Preserve aSizes(0 To lNumPolys - 1) As Long
ReDim Preserve uPoints(0 To lPos - 1) As POINTAPI
End Sub
Private Function pvFindStartVector(uVectors() As RECT, lX As Long, lY As Long) As Boolean
For lY = 0 To UBound(uVectors, 2)
For lX = 0 To UBound(uVectors, 1)
With uVectors(lX, lY)
If .Left <> 0 And .Left <> SKIP_TO Or .Top <> 0 And .Top <> SKIP_TO _
Or .Right <> 0 And .Right <> SKIP_TO Or .Bottom <> 0 And .Bottom <> SKIP_TO Then
pvFindStartVector = True
Exit Function
End If
End With
Next
Next
End Function
Private Sub pvAppendRightTurn(uPoints() As POINTAPI, ByVal lPos As Long, lSize As Long, ByVal lX As Long, ByVal lY As Long, ByVal lSteps As Long)
Dim lIdx As Long
Dim lPrevX As Long
Dim lPrevY As Long
Dim lCenterX As Long
Dim lCenterY As Long
Dim dblStartAngle As Double
Dim lTempX As Long
Dim lTempY As Long
Debug.Assert lSize > 0
lPrevX = uPoints(lPos + lSize - 1).X
lPrevY = uPoints(lPos + lSize - 1).Y
If lPrevX < lX And lPrevY < lY Then
lCenterX = lPrevX
lCenterY = lY
dblStartAngle = M_PI_2 * 3
ElseIf lPrevX < lX And Not lPrevY < lY Then
lCenterX = lX
lCenterY = lPrevY
dblStartAngle = M_PI_2 * 2
ElseIf Not lPrevX < lX And lPrevY < lY Then
lCenterX = lX
lCenterY = lPrevY
dblStartAngle = M_PI_2 * 0
ElseIf Not lPrevX < lX And Not lPrevY < lY Then
lCenterX = lPrevX
lCenterY = lY
dblStartAngle = M_PI_2 * 1
End If
For lIdx = 0 To lSteps
lTempX = Int(lCenterX + Abs(lX - lPrevX) * Cos(dblStartAngle + M_PI_2 * lIdx / lSteps) + 0.5)
lTempY = Int(lCenterY + Abs(lY - lPrevY) * Sin(dblStartAngle + M_PI_2 * lIdx / lSteps) + 0.5)
pvAppendLineTo uPoints, lPos, lSize, lTempX, lTempY
Next
Debug.Assert lTempX = lX And lTempY = lY
End Sub
Private Sub pvAppendLeftTurn(uPoints() As POINTAPI, ByVal lPos As Long, lSize As Long, ByVal lX As Long, ByVal lY As Long, ByVal lSteps As Long)
Dim lIdx As Long
Dim lPrevX As Long
Dim lPrevY As Long
Dim lCenterX As Long
Dim lCenterY As Long
Dim dblStartAngle As Double
Dim lTempX As Long
Dim lTempY As Long
Debug.Assert lSize > 0
lPrevX = uPoints(lPos + lSize - 1).X
lPrevY = uPoints(lPos + lSize - 1).Y
If lPrevX < lX And lPrevY < lY Then
lCenterX = lX
lCenterY = lPrevY
dblStartAngle = M_PI_2 * 2
ElseIf lPrevX < lX And Not lPrevY < lY Then
lCenterX = lPrevX
lCenterY = lY
dblStartAngle = M_PI_2 * 1
ElseIf Not lPrevX < lX And lPrevY < lY Then
lCenterX = lPrevX
lCenterY = lY
dblStartAngle = M_PI_2 * 3
ElseIf Not lPrevX < lX And Not lPrevY < lY Then
lCenterX = lX
lCenterY = lPrevY
dblStartAngle = M_PI_2 * 0
End If
For lIdx = 0 To lSteps
lTempX = Int(lCenterX + Abs(lX - lPrevX) * Cos(dblStartAngle - M_PI_2 * lIdx / lSteps) + 0.5)
lTempY = Int(lCenterY + Abs(lY - lPrevY) * Sin(dblStartAngle - M_PI_2 * lIdx / lSteps) + 0.5)
pvAppendLineTo uPoints, lPos, lSize, lTempX, lTempY
Next
Debug.Assert lTempX = lX And lTempY = lY
End Sub
Private Sub pvAppendLineTo(uPoints() As POINTAPI, ByVal lPos As Long, lSize As Long, ByVal lX As Long, ByVal lY As Long)
If lSize >= 2 Then
'--- remove redundant last point if the new one is on the same line
If pvPointsInLine(uPoints(lPos + lSize - 2), uPoints(lPos + lSize - 1), lX, lY) Then
lSize = lSize - 1
End If
End If
If UBound(uPoints) < lPos + lSize Then
ReDim Preserve uPoints(0 To 2 * UBound(uPoints)) As POINTAPI
End If
With uPoints(lPos + lSize)
.X = lX
.Y = lY
End With
lSize = lSize + 1
End Sub
Private Function pvPointsInLine(uA As POINTAPI, uB As POINTAPI, ByVal lX As Long, ByVal lY As Long) As Boolean
If uA.X = lX Then
pvPointsInLine = uB.X = lX
ElseIf uA.Y = lY Then
pvPointsInLine = uB.Y = lY
Else
pvPointsInLine = (uA.X - lX) * (uA.Y - lY) = (lX - uB.X) * (lY - uB.Y)
End If
End Function |
Génération de QrCode
Répondre avec citation
Partager