I am writing a code for a project that is trying to find the minimum solution to the Vertex Cover Problem: Given a graph, find the minimum number of vertices needed to cover the graph.
I am trying to write a program for a brute force search through the entire solution space. Right now, my code works by doing the following:
Example using 4 nodes:
Check Every Single Node: Solution Space: {1}, {2}, {3}, {4}
Check Every Couple of Nodes: Solution Space: {1,2}, {1,3}, {1,4}, {2,3}, {2,4}, {3,4}
Check Every Triple of Nodes: Solution Space: {1,2,3}, {1,2,4}, {2,3,4}
Check Every Quadruple of Nodes: Solution Space: {1,2,3,4}
Currently, my code works for 5 nodes. The problem is that it searches through these permutations using a fixed number of nested while loops. If I wanted to run 6 nodes, I would need to add in another While loop. I am trying to generalize the code so that the number of nodes can itself be a variable.
The code finds a solution by triggering a row of binary numbers based on the solution space above, eg if the solution being tried is {1,2,4} then the first, second, and fourth binary value will be set to equal 1 while the third is set to 0. A matrix is set up to use these inputs to determine if they cover the graph. Here is a picture further showing how this works.
Any ideas on how to generalize this to any number of nodes? Thoughts on recursion?
Also, note in the code there is a section that waits for 1 second. This is just for aesthetics, it is not serving any purpose besides making the code fun to watch.
i = 0
j = 0
k = 0
m = 0
Range("Z22").Select
While i < 5 'Checks to see if a single vertice can cover the graph.
Cells(5, 20 + i).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + i) = 0
i = i + 1
End If
Wend
i = 0
While i < 4 'Checks to see if two vertices can cover the graph
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
k = 0
While k < 3 'Checks to see if three vertices can cover the graph
Cells(5, 20 + k) = 1
i = k + 1
While i < 4
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
Cells(5, 20 + k).Value = 0
k = k + 1
Wend
While m < 2 'Checks to see if four vertices can cover the graph
Cells(5, 20 + m).Value = 1
k = m + 1
While k < 3
Cells(5, 20 + k) = 1
i = k + 1
While i < 4
Cells(5, 20 + i).Value = 1
j = i + 1
While j < 5
Cells(5, 20 + j).Value = 1
Application.Wait (Now + TimeValue("0:00:1"))
If Cells(21, 13).Value = Cells(22, 26).Value Then
GoTo Line1
Else
Cells(5, 20 + j) = 0
j = j + 1
End If
Wend
Cells(5, 20 + i) = 0
i = i + 1
Wend
Cells(5, 20 + k).Value = 0
k = k + 1
Wend
Cells(5, 20 + m).Value = 0
m = m + 1
Wend
If Cells(21, 13).Value <> Cells(22, 26).Value Then 'Final effort
Range("T5:X5") = 1
MsgBox ("It takes all five vertices.")
End If
Line1:
Application.DisplayAlerts = True
End Sub
This makes combinations for any n; does not use recursion. I've got to think if recursion would be applicable (make it simpler?)
Option Explicit
Const nnodes = 6
Dim a&(), icol&
Sub Main()
ThisWorkbook.Sheets("sheet1").Activate
Cells.Delete
Dim i&, j&
For i = 1 To nnodes ' from 1 to nnodes
ReDim a(i)
For j = 1 To i ' -- start with 1 up
a(j) = j
Next j
Cells(i, 1) = i ' show
icol = 2 ' for show
Do ' -- show combination and get next combination
Loop While doi(i)
Next i
End Sub
Function doi(i) As Boolean ' show and get next
Dim j&, s$
For j = 1 To i ' build string for show
If j > 1 Then s = s & ","
s = s & Str$(a(j))
Next j
Cells(i, icol) = "{" & s & "}" ' show
icol = icol + 1
' -- get next combination (if)
For j = i To 1 Step -1 ' check if any more
If a(j) < nnodes - i + j Then Exit For
Next j
If j < 1 Then doi = False: Exit Function ' no more
a(j) = a(j) + 1 ' build next combination
While j < i
a(j + 1) = a(j) + 1
j = j + 1
Wend
doi = True
End Function
EDIT: Changed "permutation" to "combination".
EDIT2: I kept coming back to recursion -- it does simplify the code:
Option Explicit
Dim icol& ' for showing combinations
Sub Main() ' get (non-empty) partitions of nnodes
Const nnodes = 6
Dim k&
ThisWorkbook.Sheets("sheet2").Activate
Cells.Delete
For k = 1 To nnodes ' k = 1 to n
Cells(k, 1) = k ' for showing
icol = 2
Call Comb("", 0, 1, nnodes, k) ' combinations(n,k)
Next k
End Sub
Sub Comb(s$, lens&, i&, n&, k&) ' build combination
Dim s2$, lens2&, j&
For j = i To n + lens + 1 - k '
If lens = 0 Then s2 = s Else s2 = s & ", "
s2 = s2 & j
lens2 = lens + 1
If lens2 = k Then ' got it?
Cells(k, icol) = "{" & s2 & "}" ' show combination
icol = icol + 1
Else
Call Comb(s2, lens2, j + 1, n, k) ' recurse
End If
Next j
End Sub
I have a for loop that takes a user's input and one of the keys in my dictionary and passes them to a Damerau-Levenshtein function and based on the distance, overwrites the user's input with the dictionary key (The for loop is to cycle through each dictionary key). This works fine enough for strings larger than three characters, but if the string is three or fewer characters the algorithm returns with the wrong key. Here's the for loop:
1950 For j = 0 To dict.Count - 1
1960 distance = DamerauLevenshtein(SplitStr(i), dict.Keys(j))
1970 'MsgBox dict.Keys(j) & vbCrLf & distance ' used for debugging
1980 If distance < 4 Then
1990 If distance < leastDist Then
2000 leastDist = distance
2010 SplitStr(i) = dict.Keys(j)
2020 End If
2030 End If
2040 Next
2050 MsgBox "The distance is: " & leastDist & vbCrLf & "The entered text was " & tempStr & vbCrLf & "The replaced word is " & SplitStr(i)
SplitStr(i) holds the user's input, which comes from a split function. I arbitrarily picked 4 for a good distance
I stole the algorithm from a bytes.com forum post. Algorithm below:
Function DamerauLevenshtein(str1, str2, Optional intSize = 256)
Dim intTotalLen, arrDistance, intLen1, intLen2, i, j, arrStr1, arrStr2, arrDA, intMini
Dim intDB, intI1, intJ1, intD
str1 = UCase(str1)
str2 = UCase(str2)
intLen1 = Len(str1)
intLen2 = Len(str2)
intTotalLen = intLen1 + intLen2
ReDim arrStr1(intLen1)
ReDim arrStr2(intLen2)
ReDim arrDA(intSize)
ReDim arrDistance(intLen1 + 2, intLen2 + 2)
arrDistance(0, 0) = intTotalLen
For i = 0 To intSize - 1
arrDA(i) = 0
Next
For i = 0 To intLen1
arrDistance(i + 1, 1) = i
arrDistance(i + 1, 0) = intTotalLen
Next
For i = 1 To intLen1
arrStr1(i - 1) = Asc(Mid(str1, i, 1))
Next
For j = 0 To intLen2
arrDistance(1, j + 1) = j
arrDistance(0, j + 1) = intTotalLen
Next
For j = 1 To intLen2
arrStr2(j - 1) = Asc(Mid(str2, j, 1))
Next
For i = 1 To intLen1
intDB = 0
For j = 1 To intLen2
intI1 = arrDA(arrStr2(j - 1))
intJ1 = intDB
If arrStr1(i - 1) = arrStr2(j - 1) Then
intD = 0
Else
intD = 1
End If
If intD = 0 Then intDB = j
intMini = arrDistance(i, j) + intD
If intMini > arrDistance(i + 1, j) + 1 Then intMini = arrDistance(i + 1, j) + 1
If intMini > arrDistance(i, j + 1) + 1 Then intMini = arrDistance(i, j + 1) + 1
If intMini > arrDistance(intI1, intJ1) + i - intI1 + j - intJ1 - 1 Then intMini = arrDistance(intI1, intJ1) + i - intI1 + j - intJ1 - 1
arrDistance(i + 1, j + 1) = intMini
Next
arrDA(arrStr1(i - 1)) = i
Next
DamerauLevenshtein = arrDistance(intLen1 + 1, intLen2 + 1)
End Function
If I type in "Cire" the algorithm correctly returns "CORE".
"Raman" returns "REMAN"
"Cosnigned" returns "CONSIGNED
However, "Now" should return "New" but returns "OCM".
"New" also returns "OCM" (so distance should be 0, but is 2.)
"FP" should be "FP" but returns "OCM", distance is 2
"DPF" Should be "DPF" but returns "OCM", distance is 2
I just learned about the algorithm, so I'm sure I'm missing something important, but I just can't see it. Thoughts?
I figured it out. After much searching I found a post saying that an edit distance is commonly 2. (They didn't specify any merits on why 2 is common)
I switched my if statement to 2 from 4 and now all of the problem terms are being corrected as they should be.
I'm getting "error13 type mismatch" when iterating over all worksheets in the workbook in line 7 of the code (If ActiveSheet.Cells(1, 47) = 1 Then). Does anyone know how to fix this?
Dim y As Integer
Dim c As Integer
Dim ws_num As Integer
Dim starting_ws As Worksheet
Set starting_ws = ActiveSheet 'remember which worksheet is active in the beginning
ws_num = ThisWorkbook.Worksheets.Count
For y = 1 To ws_num
ThisWorkbook.Worksheets(y).Activate
If ActiveSheet.Cells(1, 47) = 1 Then
Worksheets("Podsumowanie").Cells(2, y + 1) = ThisWorkbook.Worksheets(y).Range("U2")
Worksheets("Podsumowanie").Cells(3, y + 1) = ThisWorkbook.Worksheets(y).Range("V2")
Worksheets("Podsumowanie").Cells(4, y + 1) = ThisWorkbook.Worksheets(y).Range("W2")
Worksheets("Podsumowanie").Cells(5, y + 1) = ThisWorkbook.Worksheets(y).Range("P3")
Worksheets("Podsumowanie").Cells(6, y + 1) = ThisWorkbook.Worksheets(y).Range("Q3")
Worksheets("Podsumowanie").Cells(7, y + 1) = ThisWorkbook.Worksheets(y).Range("R3")
Worksheets("Podsumowanie").Cells(8, y + 1) = ThisWorkbook.Worksheets(y).Range("S3")
Else
Worksheets("Podsumowanie").Cells(2, y + 1) = ThisWorkbook.Worksheets(y).Range("U2")
Worksheets("Podsumowanie").Cells(3, y + 1) = ThisWorkbook.Worksheets(y).Range("V2")
Worksheets("Podsumowanie").Cells(4, y + 1) = ThisWorkbook.Worksheets(y).Range("W2")
Worksheets("Podsumowanie").Cells(5, y + 1) = ThisWorkbook.Worksheets(y).Range("P8")
Worksheets("Podsumowanie").Cells(6, y + 1) = ThisWorkbook.Worksheets(y).Range("Q8")
Worksheets("Podsumowanie").Cells(7, y + 1) = ThisWorkbook.Worksheets(y).Range("R8")
Worksheets("Podsumowanie").Cells(8, y + 1) = ThisWorkbook.Worksheets(y).Range("S8")
End If
Next
Try using this instead
Dim y As Long
Dim PodSheet As Worksheet
Set PodSheet = ThisWorkbook.Sheets("Podsumowanie")
For y = 1 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Sheets(y)
If .Cells(1, 47).Value2 = 1 Then
PodSheet.Cells(2, y + 1) = .Range("U2")
PodSheet.Cells(3, y + 1) = .Range("V2")
PodSheet.Cells(4, y + 1) = .Range("W2")
PodSheet.Cells(5, y + 1) = .Range("P3")
PodSheet.Cells(6, y + 1) = .Range("Q3")
PodSheet.Cells(7, y + 1) = .Range("R3")
PodSheet.Cells(8, y + 1) = .Range("S3")
Else
PodSheet.Cells(2, y + 1) = .Range("U2")
PodSheet.Cells(3, y + 1) = .Range("V2")
PodSheet.Cells(4, y + 1) = .Range("W2")
PodSheet.Cells(5, y + 1) = .Range("P8")
PodSheet.Cells(6, y + 1) = .Range("Q8")
PodSheet.Cells(7, y + 1) = .Range("R8")
PodSheet.Cells(8, y + 1) = .Range("S8")
End If
End With
Next y
Type Mismatch error is caused when Cells(1, 47) contains an error - to avoid it use IsError()
Another issue will be caused when the cell is empty or doesn't contain a number
You can also minimize repetition like in Tom's answer, and not .Activate each sheet
This contains all suggestions, but is not tested (you didn't include the full procedure)
Dim y As Long, c As Long, thisCol As Long, pCol As Long
Dim ws As Worksheet, podWs As Worksheet, cel As Range
Set podWs = ThisWorkbook.Worksheets("Podsumowanie")
For Each ws In ThisWorkbook.Worksheets
With ws
pCol = .Index + 1
podWs.Cells(2, pCol) = .Range("U2")
podWs.Cells(3, pCol) = .Range("V2")
podWs.Cells(4, pCol) = .Range("W2")
Set cel = .Cells(1, 47)
If Not IsError(cel) Then
If IsNumeric(cel.Value2) Then
thisCol = IIf(cel = 1, 3, 8)
podWs.Cells(5, pCol) = .Range("P" & thisCol)
podWs.Cells(6, pCol) = .Range("Q" & thisCol)
podWs.Cells(7, pCol) = .Range("R" & thisCol)
podWs.Cells(8, pCol) = .Range("S" & thisCol)
End If
End If
End With
Next
Context
I am using barcode-vba-macro-only (mentioned in this SO post) in MS Excel 2010 to generate a QR code.
(The bar code will be used to facilitate paying a bill using Girocode, but that is not important here, except to say I need to structure the input exactly the way shown below.)
The problem
The VBA macro creates great QR-Codes, but somehow, when given certain input, the output (encoded in the QR code) "stutters", i.e. repeats part of the text.
E.g., when given this input:
BCD
001
1
SCT
SOLADES1HDB
Recipient First and Last Name
DE86672500200000123456
EUR123.45
it produces this output:
which oddly repeats part of the content:
BCD
001
1
SCT
SOLADES1HDB
Recipient First and Last Name
DE
Recipient First and Last Name
DE86672500200000123456
EUR123.45
(Note the DE and the line Recipient First and Last Name which appear twice.)
What I want
A working, free/GPL solution in Excel to generate such codes ;-) ... for example by understanding why this happens, and fixing the VBA code.
What I have tried (Update 1)
I have played around with different inputs and found that just adding some extra "AAA" to the end of the long number solves the stuttering... so I am intrigued what causes this.
I forked to code on GitHub, added some code comments and translated a few of the existing (Czech) comments
Through some debugging, I found that the implementation messes up the starting position of different encodings (which it stores in array eb): after encoding the "Recipient First and Last Name" including newline and "DE" as "Byte", it probably tries to switch to "Decimal" or "Alphanum" encoding (only 3.33 or 5.5 bit per character instead of 8)... but then falls back to encoding in "Byte" format and thereby gets the starting position wrong.
The code
You can download my test XLSM file here, and access my improved code file on GitHub.
I think the issue is probably in the core function shown below, in the section where the array eb() is filled.
Function qr_gen(ptext As String, poptions As String) As String
Dim encoded1() As Byte ' byte mode (ASCII) all max 3200 bytes
Dim encix1%
Dim ecx_cnt(3) As Integer
Dim ecx_pos(3) As Integer
Dim ecx_poc(3) As Integer
Dim eb(1 To 20, 1 To 4) As Integer 'store how many characters should be in which ECI mode. This is a list of rows, each row corresponding a the next batch of characters with a different ECI mode.
' eb(i, 1) - ECI mode (1 = numeric, 2 = alphanumeric, 3 = byte)
' eb(i, 2) - last character in previous row
' eb(i, 3) - number of characters in THIS row
' eb(i, 4) - number of bits for THIS row
Dim ascimatrix$, mode$, err$
Dim ecl%, r%, c%, mask%, utf8%, ebcnt%
Dim i&, j&, k&, m&
Dim ch%, s%, siz%
Dim x As Boolean
Dim qrarr() As Byte ' final matrix
Dim qrpos As Integer
Dim qrp(15) As Integer ' 1:version,2:size,3:ccs,4:ccb,5:totby,6-12:syncs(7),13-15:versinfo(3)
Dim qrsync1(1 To 8) As Byte
Dim qrsync2(1 To 5) As Byte
ascimatrix = ""
err = ""
mode = "M"
i = InStr(poptions, "mode=")
If i > 0 Then mode = Mid(poptions, i + 5, 1)
' M=0,L=1,H=2,Q=3
ecl = InStr("MLHQ", mode) - 1
If ecl < 0 Then mode = "M": ecl = 0
If ptext = "" Then
err = "Not data"
Exit Function
End If
For i = 1 To 3
ecx_pos(i) = 0
ecx_cnt(i) = 0
ecx_poc(i) = 0
Next i
ebcnt = 1
utf8 = 0
For i = 1 To Len(ptext) + 1
' Decide how many bytes this character has
If i > Len(ptext) Then
k = -5 ' End of text --> skip several code sections
Else ' need to parse character i of ptext and decide how many bytes it has
k = AscL(Mid(ptext, i, 1))
If k >= &H1FFFFF Then ' FFFF - 1FFFFFFF
m = 4
k = -1
ElseIf k >= &H7FF Then ' 7FF-FFFF 3 bytes
m = 3
k = -1
ElseIf k >= 128 Then
m = 2
k = -1
Else ' normal 7bit ASCII character, so it is worth it to check if it belong to the Numeric or Alphanumeric subsets defined in ECI (array qralnum)
m = 1
k = InStr(qralnum, Mid(ptext, i, 1)) - 1
End If
End If
' Depending on k and a lot of other things, increase ebcnt
If (k < 0) Then ' Treat mult-byte case or exit? (bude byte nebo konec)
If ecx_cnt(1) >= 9 Or (k = -5 And ecx_cnt(1) = ecx_cnt(3)) Then ' Until now it was possible numeric??? (Az dosud bylo mozno pouzitelne numeric)
If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then ' pred num je i pouzitelny alnum
If (ecx_cnt(3) > ecx_cnt(2)) Then ' Jeste pred alnum bylo byte
eb(ebcnt, 1) = 3 ' Typ byte
eb(ebcnt, 2) = ecx_pos(3) ' Position pozice
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2) ' delka
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 2 ' Typ alnum
eb(ebcnt, 2) = ecx_pos(2)
eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1) ' delka
ebcnt = ebcnt + 1
ecx_poc(2) = ecx_poc(2) + 1
ecx_cnt(2) = 0
ElseIf ecx_cnt(3) > ecx_cnt(1) Then ' byly bytes pred numeric
eb(ebcnt, 1) = 3 ' Typ byte
eb(ebcnt, 2) = ecx_pos(3) ' Position pozice
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(1) ' delka
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
ElseIf (ecx_cnt(2) >= 8) Or (k = -5 And ecx_cnt(2) = ecx_cnt(3)) Then ' Az dosud bylo mozno pouzitelne alnum
If (ecx_cnt(3) > ecx_cnt(2)) Then ' Jeste pred alnum bylo byte
eb(ebcnt, 1) = 3 ' Typ byte
eb(ebcnt, 2) = ecx_pos(3) ' Position pozice
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2) ' delka
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 2 ' Typ alnum
eb(ebcnt, 2) = ecx_pos(2)
eb(ebcnt, 3) = ecx_cnt(2) ' delka
ebcnt = ebcnt + 1
ecx_poc(2) = ecx_poc(2) + 1
ecx_cnt(3) = 0
ecx_cnt(2) = 0 ' vse zpracovano
ElseIf (k = -5 And ecx_cnt(3) > 0) Then ' konec ale mam co ulozit
eb(ebcnt, 1) = 3 ' Typ byte
eb(ebcnt, 2) = ecx_pos(3) ' Position pozice
eb(ebcnt, 3) = ecx_cnt(3) ' delka
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
End If
If k = -5 Then Exit For
If (k >= 0) Then ' We can alphanumeric? (Muzeme alnum)
If (k >= 10 And ecx_cnt(1) >= 12) Then ' Until now it was perhaps numeric (Az dosud bylo mozno num)
If (ecx_cnt(2) - ecx_cnt(1)) >= 8 Or (ecx_cnt(3) = ecx_cnt(2)) Then ' There is also an alphanumeric which is worth it(Je tam i alnum ktery stoji za to)
If (ecx_cnt(3) > ecx_cnt(2)) Then ' Even before it was alnum byte (Jeste pred alnum bylo byte)
eb(ebcnt, 1) = 3 ' Typ byte
eb(ebcnt, 2) = ecx_pos(3) ' Position (pozice)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(2) ' length (delka)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 2 ' Typ alnum
eb(ebcnt, 2) = ecx_pos(2)
eb(ebcnt, 3) = ecx_cnt(2) - ecx_cnt(1) ' length (delka)
ebcnt = ebcnt + 1
ecx_poc(2) = ecx_poc(2) + 1
ecx_cnt(2) = 0 ' processed everything (vse zpracovano)
ElseIf (ecx_cnt(3) > ecx_cnt(1)) Then ' Previous Num is byte (Pred Num je byte)
eb(ebcnt, 1) = 3 ' Typ byte
eb(ebcnt, 2) = ecx_pos(3) ' Position (pozice)
eb(ebcnt, 3) = ecx_cnt(3) - ecx_cnt(1) ' length (delka)
ebcnt = ebcnt + 1
ecx_poc(3) = ecx_poc(3) + 1
End If
eb(ebcnt, 1) = 1 ' Typ numerix
eb(ebcnt, 2) = ecx_pos(1)
eb(ebcnt, 3) = ecx_cnt(1) ' length (delka)
ebcnt = ebcnt + 1
ecx_poc(1) = ecx_poc(1) + 1
ecx_cnt(1) = 0
ecx_cnt(2) = 0
ecx_cnt(3) = 0 ' processed everything (vse zpracovano)
End If
If ecx_cnt(2) = 0 Then ecx_pos(2) = i
ecx_cnt(2) = ecx_cnt(2) + 1
Else ' possible alnum (mozno alnum)
ecx_cnt(2) = 0
End If
If k >= 0 And k < 10 Then ' Can be numeric (muze byt numeric)
If ecx_cnt(1) = 0 Then ecx_pos(1) = i
ecx_cnt(1) = ecx_cnt(1) + 1
Else
ecx_cnt(1) = 0
End If
If ecx_cnt(3) = 0 Then ecx_pos(3) = i
ecx_cnt(3) = ecx_cnt(3) + m
utf8 = utf8 + m
If ebcnt >= 16 Then ' We have already taken 3 other blocks of bits (Uz by se mi tri dalsi bloky stejne nevesli)
ecx_cnt(1) = 0
ecx_cnt(2) = 0
End If
Debug.Print "Character:'" & Mid(ptext, i, 1) & "'(" & k & _
") ebn=" & ecx_pos(1) & "." & ecx_cnt(1) & _
" eba=" & ecx_pos(2) & "." & ecx_cnt(2) & _
" ebb=" & ecx_pos(3) & "." & ecx_cnt(3)
Next
ebcnt = ebcnt - 1 ' ebcnt now has its final value
Debug.Print ("ebcnt=" & ebcnt)
c = 0
For i = 1 To ebcnt
Select Case eb(i, 1)
Case 1: eb(i, 4) = Int(eb(i, 3) / 3) * 10 + (eb(i, 3) Mod 3) * 3 + IIf((eb(i, 3) Mod 3) > 0, 1, 0)
Case 2: eb(i, 4) = Int(eb(i, 3) / 2) * 11 + (eb(i, 3) Mod 2) * 6
Case 3: eb(i, 4) = eb(i, 3) * 8
End Select
c = c + eb(i, 4)
Next i
Debug.Print ("c=" & c)
' UTF-8 is default not need ECI value - zxing cannot recognize
' Call qr_params(i * 8 + utf8,mode,qrp)
Call qr_params(c, ecl, qrp, ecx_poc)
If qrp(1) <= 0 Then
err = "Too long"
Exit Function
End If
siz = qrp(2)
Debug.Print "ver:" & qrp(1) & mode & " size " & siz & " ecc:" & qrp(3) & "x" & qrp(4) & " d:" & (qrp(5) - qrp(3) * qrp(4))
'MsgBox "ver:" & qrp(1) & mode & " size " & siz & " ecc:" & qrp(3) & "x" & qrp(4) & " d:" & (qrp(5) - qrp(3) * qrp(4))
ReDim encoded1(qrp(5) + 2)
' Table 3 — Number of bits in character count indicator for QR Code 2005:
' mode indicator (1=num,2=AlNum,4=Byte,8=kanji,ECI=7)
' mode: Byte Alphanum Numeric Kanji
' ver 1..9 : 8 9 10 8
' 10..26 : 16 11 12 10
' 27..40 : 16 13 14 12
' UTF-8 is default not need ECI value - zxing cannot recognize
' if utf8 > 0 Then
' k = &H700 + 26 ' UTF-8=26 ; Win1250 = 21; 8859-2 = 4 viz http://strokescribe.com/en/ECI.html
' bb_putbits(encoded1,encix1,k,12)
' End If
encix1 = 0
For i = 1 To ebcnt
Select Case eb(i, 1)
Case 1: c = IIf(qrp(1) < 10, 10, IIf(qrp(1) < 27, 12, 14)): k = 2 ^ c + eb(i, 3) ' encoding mode "Numeric"
Case 2: c = IIf(qrp(1) < 10, 9, IIf(qrp(1) < 27, 11, 13)): k = 2 * (2 ^ c) + eb(i, 3) ' encoding mode "alphanum
Case 3: c = IIf(qrp(1) < 10, 8, 16): k = 4 * (2 ^ c) + eb(i, 3) ' encoding mode "Byte"
End Select
Call bb_putbits(encoded1, encix1, k, c + 4)
Debug.Print "ver:" & qrp(1) & mode & " size " & siz & " ecc:" & qrp(3) & "x" & qrp(4) & " d:" & (qrp(5) - qrp(3) * qrp(4))
j = 0 ' count characters that have been output in THIS row eb(i,...)
m = eb(i, 2) 'Start (after) last character of input from previous row
r = 0
While j < eb(i, 3)
k = AscL(Mid(ptext, m, 1))
m = m + 1
If eb(i, 1) = 1 Then
' parse numeric input - output 3 decimal digits into 10 bit
r = (r * 10) + ((k - &H30) Mod 10)
If (j Mod 3) = 2 Then
Call bb_putbits(encoded1, encix1, r, 10)
r = 0
End If
j = j + 1
ElseIf eb(i, 1) = 2 Then
' parse alphanumeric input - output 2 alphanumeric characters into 11 bit
r = (r * 45) + ((InStr(qralnum, Chr(k)) - 1) Mod 45)
If (j Mod 2) = 1 Then
Call bb_putbits(encoded1, encix1, r, 11)
r = 0
End If
j = j + 1
Else
' Okay, byte mode: coding according to Chapter "6.4.2 Extended Channel Interpretation (ECI) mode" of ISOIEC 18004_2006Cor 1_2009.pdf
If k > &H1FFFFF Then ' FFFF - 1FFFFFFF
ch = &HF0 + Int(k / &H40000) Mod 8
Call bb_putbits(encoded1, encix1, ch, 8)
ch = 128 + Int(k / &H1000) Mod 64
Call bb_putbits(encoded1, encix1, ch, 8)
ch = 128 + Int(k / 64) Mod 64
Call bb_putbits(encoded1, encix1, ch, 8)
ch = 128 + k Mod 64
Call bb_putbits(encoded1, encix1, ch, 8)
j = j + 4
ElseIf k > &H7FF Then ' 7FF-FFFF 3 bytes
ch = &HE0 + Int(k / &H1000) Mod 16
Call bb_putbits(encoded1, encix1, ch, 8)
ch = 128 + Int(k / 64) Mod 64
Call bb_putbits(encoded1, encix1, ch, 8)
ch = 128 + k Mod 64
Call bb_putbits(encoded1, encix1, ch, 8)
j = j + 3
ElseIf k > &H7F Then ' 2 bytes
ch = &HC0 + Int(k / 64) Mod 32
Call bb_putbits(encoded1, encix1, ch, 8)
ch = 128 + k Mod 64
Call bb_putbits(encoded1, encix1, ch, 8)
j = j + 2
Else
ch = k Mod 256
Call bb_putbits(encoded1, encix1, ch, 8)
j = j + 1
End If
End If
Wend
Select Case eb(i, 1)
Case 1:
If (j Mod 3) = 1 Then
Call bb_putbits(encoded1, encix1, r, 4)
ElseIf (j Mod 3) = 2 Then
Call bb_putbits(encoded1, encix1, r, 7)
End If
Case 2:
If (j Mod 2) = 1 Then Call bb_putbits(encoded1, encix1, r, 6)
End Select
'MsgBox "blk[" & i & "] t:" & eb(i,1) & "from " & eb(i,2) & " to " & eb(i,3) + eb(i,2) & " bits=" & encix1
Next i
Call bb_putbits(encoded1, encix1, 0, 4) ' end of chain
If (encix1 Mod 8) <> 0 Then ' round to byte
Call bb_putbits(encoded1, encix1, 0, 8 - (encix1 Mod 8))
End If
' padding
i = (qrp(5) - qrp(3) * qrp(4)) * 8
If encix1 > i Then
err = "Encode length error"
Exit Function
End If
' padding 0xEC,0x11,0xEC,0x11...
Do While encix1 < i
Call bb_putbits(encoded1, encix1, &HEC11, 16)
Loop
' doplnime ECC
i = qrp(3) * qrp(4) 'ppoly, pmemptr , psize , plen , pblocks
Call qr_rs(&H11D, encoded1, qrp(5) - i, i, qrp(4))
'Call arr2hexstr(encoded1)
encix1 = qrp(5)
' Pole pro vystup
ReDim qrarr(0)
ReDim qrarr(1, qrp(2) * 24& + 24&) ' 24 bytes per row
qrarr(0, 0) = 0
ch = 0
Call bb_putbits(qrsync1, ch, Array(&HFE, &H82, &HBA, &HBA, &HBA, &H82, &HFE, 0), 64)
Call qr_mask(qrarr, qrsync1, 8, 0, 0) ' sync UL
Call qr_mask(qrarr, 0, 8, 8, 0) ' fmtinfo UL under - bity 14..9 SYNC 8
Call qr_mask(qrarr, qrsync1, 8, 0, siz - 7) ' sync UR ( o bit vlevo )
Call qr_mask(qrarr, 0, 8, 8, siz - 8) ' fmtinfo UR - bity 7..0
Call qr_mask(qrarr, qrsync1, 8, siz - 7, 0) ' sync DL (zasahuje i do quiet zony)
Call qr_mask(qrarr, 0, 8, siz - 8, 0) ' blank nad DL
For i = 0 To 6
x = qr_bit(qrarr, -1, i, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7
x = qr_bit(qrarr, -1, i, siz - 8, 0) ' svisly blank pred UR
x = qr_bit(qrarr, -1, siz - 1 - i, 8, 0) ' svisle fmtinfo DL - bity 14..8
Next
x = qr_bit(qrarr, -1, 7, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7
x = qr_bit(qrarr, -1, 7, siz - 8, 0) ' svisly blank pred UR
x = qr_bit(qrarr, -1, 8, 8, 0) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7
x = qr_bit(qrarr, -1, siz - 8, 8, 1) ' black dot DL
If qrp(13) <> 0 Or qrp(14) <> 0 Then ' versioninfo
' UR ver 0 1 2;3 4 5;...;15 16 17
' LL ver 0 3 6 9 12 15;1 4 7 10 13 16; 2 5 8 11 14 17
k = 65536 * qrp(13) + 256& * qrp(14) + 1& * qrp(15)
c = 0: r = 0
For i = 0 To 17
ch = k Mod 2
x = qr_bit(qrarr, -1, r, siz - 11 + c, ch) ' UR ver
x = qr_bit(qrarr, -1, siz - 11 + c, r, ch) ' DL ver
c = c + 1
If c > 2 Then c = 0: r = r + 1
k = Int(k / 2&)
Next
End If
c = 1
For i = 8 To siz - 9 ' sync lines
x = qr_bit(qrarr, -1, i, 6, c) ' vertical on column 6
x = qr_bit(qrarr, -1, 6, i, c) ' horizontal on row 6
c = (c + 1) Mod 2
Next
' other syncs
ch = 0
Call bb_putbits(qrsync2, ch, Array(&H1F, &H11, &H15, &H11, &H1F), 40)
ch = 6
Do While ch > 0 And qrp(6 + ch) = 0
ch = ch - 1
Loop
If ch > 0 Then
For c = 0 To ch
For r = 0 To ch
' corners
If (c <> 0 Or r <> 0) And _
(c <> ch Or r <> 0) And _
(c <> 0 Or r <> ch) Then
Call qr_mask(qrarr, qrsync2, 5, qrp(r + 6) - 2, qrp(c + 6) - 2)
End If
Next r
Next c
End If
' qr_fill(parr as Variant, psiz%, pb as Variant, pblocks%, pdlen%, ptlen%)
' vyplni pole parr (psiz x 24 bytes) z pole pb pdlen = pocet dbytes, pblocks = bloku, ptlen celkem
Call qr_fill(qrarr, siz, encoded1, qrp(4), qrp(5) - qrp(3) * qrp(4), qrp(5))
mask = 8 ' auto
i = InStr(poptions, "mask=")
If i > 0 Then mask = val(Mid(poptions, i + 5, 1))
If mask < 0 Or mask > 7 Then
j = -1
For mask = 0 To 7
GoSub addmm
i = qr_xormask(qrarr, siz, mask, False)
' MsgBox "score mask " & mask & " is " & i
If i < j Or j = -1 Then j = i: s = mask
Next mask
mask = s
' MsgBox "best is " & mask & " with score " & j
End If
GoSub addmm
i = qr_xormask(qrarr, siz, mask, True)
ascimatrix = ""
For r = 0 To siz Step 2
s = 0
For c = 0 To siz Step 2
If (c Mod 8) = 0 Then
ch = qrarr(1, s + 24 * r)
If r < siz Then i = qrarr(1, s + 24 * (r + 1)) Else i = 0
s = s + 1
End If
ascimatrix = ascimatrix _
& Chr(97 + (ch Mod 4) + 4 * (i Mod 4))
ch = Int(ch / 4)
i = Int(i / 4)
Next
ascimatrix = ascimatrix & vbNewLine
Next r
ReDim qrarr(0)
qr_gen = ascimatrix
Exit Function
addmm:
k = ecl * 8 + mask
' poly: 101 0011 0111
Call qr_bch_calc(k, &H537)
'MsgBox "mask :" & hex(k,3) & " " & hex(k xor &H5412,3)
k = k Xor &H5412 ' micro xor &H4445
r = 0
c = siz - 1
For i = 0 To 14
ch = k Mod 2
k = Int(k / 2)
x = qr_bit(qrarr, -1, r, 8, ch) ' svisle fmtinfo UL - bity 0..5 SYNC 6,7 .... 8..14 dole
x = qr_bit(qrarr, -1, 8, c, ch) ' vodorovne odzadu 0..7 ............ 8,SYNC,9..14
c = c - 1
r = r + 1
If i = 7 Then c = 7: r = siz - 7
If i = 5 Then r = r + 1 ' preskoc sync vodorvny
If i = 8 Then c = c - 1 ' preskoc sync svisly
Next
Return
End Function ' qr_gen
Why this happens
Through some debugging, I found that the original implementation messes up the starting position of different encodings (which it stores in array eb): after encoding the "Recipient First and Last Name" including newline and "DE" as "Byte", it probably tries to switch to "Decimal" or "Alphanum" encoding (only 3.33 or 5.5 bit per character instead of 8)... but then falls back to encoding in "Byte" format and thereby gets the starting position wrong.
The solution
I have now added some error checking to the code which manually removes the stuttering.
You can find my improved code on Github, see in particular barcody.bas.
The key addition is this part:
i = 1
While i < (ebcnt - 1)
If eb(i, 2) + eb(i, 3) <> eb(i + 1, 2) Then
' oops, this should not happen. First document it:
Debug.Print ("eb() rows " & i & " and " & i + 1 & " are overlapping!")
' Now Lets see if we can fix it:
wasfixed = False
For k = i To 1 Step -1
If eb(k, 2) = eb(i + 1, 2) Then
' okay, the row k to i seem to be contained in i+1 and following. Delete k to i ...
For j = k To ebcnt - (i - k + 1) ' ... by copying upwards all later rows...
eb(j, 1) = eb(j + (i - k + 1), 1)
eb(j, 2) = eb(j + (i - k + 1), 2)
eb(j, 3) = eb(j + (i - k + 1), 3)
eb(j, 4) = eb(j + (i - k + 1), 4)
Next j
ebcnt = ebcnt - (i - k + 1) ' and correcting the total rowcount
wasfixed = True
Exit For
End If
Next k
If Not (wasfixed) Then
MsgBox ("The input text analysis failed - entering debug mode...")
Debug.Assert False
End If
End If
i = i + 1
Wend
I have noticed this same issue with certain character being a trigger for this problem when it comes after something. In your case, it looks like something after "DE" Since I didn't write the code I haven't thoroughly search in the code why this would trigger a repeat but I'm guessing that some of the hex conversion in the function causes this problem. In my case, I avoided the issue by having a space in front of the entire string being input to the generator. For some reasons, having the space at the beginning somehow prevent the triggering of the repeat. The reader program that reads the barcode in my case would remove the space from the string anyway so it doesn't matter.
I don't know whether it's a problem for your application, but try putting a blank space (" ") in front of the problematic string (DE86672500200000123456 )and see whether that works.
BCD
001
1
SCT
SOLADES1HDB
Recipient First and Last Name
DE86672500200000123456
EUR123.45