Here is code to read Barcode & QRCode using ZXing
Just download the library, create the form, add the button & list
https://sourceforge.net/projects/zxing.mirror/
NB : If some of you request, I have code to analyse Payconiq QRCode, generation of Payconiq QRCode etc...
Just download the library, create the form, add the button & list
Code:
Option Explicit
' *** Structures Needed For Registry Prototypes
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Type STARTUPINFO
CB As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OemToCharBuff Lib "USER32" Alias "OemToCharBuffA" (lpszSrc As Any, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long
Private Const NORMAL_PRIORITY_CLASS = &H20&
Private Const INFINITE = -1&
' DuplicateHandle flags
Private Const DUPLICATE_CLOSE_SOURCE = &H1
Private Const DUPLICATE_SAME_ACCESS = &H2
' Error codes
Private Const ERROR_BROKEN_PIPE = 109
' STARTUPINFO flags
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESTDHANDLES = &H100
' ShowWindow flags
Private Const SW_HIDE = 0
Public Function GetStringBetweenTags(ByVal sSearchIn As String, ByVal sFrom As String, ByVal sUntil As String, Optional nPosAfter As Long, Optional ByRef nStartAtPos As Long = 0) As String
' #VBIDEUtils#***********************************************************
' * Programmer Name :
' * Web Site :
' * E-Mail :
' * Date : 01/15/2001
' * Time : 13:31
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : GetStringBetweenTags
' * Parameters :
' * ByVal sSearchIn As String
' * ByVal sFrom As String
' * ByVal sUntil As String
' * Optional nPosAfter As Long
' * Optional ByRef nStartAtPos As Long = 0
' **********************************************************************
' * Comments :
' * This function gets in a string and two keywords
' * and returns the string between the keywords
' *
' **********************************************************************
Dim nPos1 As Long
Dim nPos2 As Long
Dim nPos As Long
'Dim nLen As Long
nPos1 = InStr(nStartAtPos + 1, sSearchIn, sFrom, vbTextCompare)
nPos2 = InStr(nPos1 + Len(sFrom), sSearchIn, sUntil, vbTextCompare)
If (nPos1 > 0) And (nPos2 > 0) Then
Dim sFound As String
sFound = Mid$(sSearchIn, nPos1 + Len(sFrom), nPos2 - (nPos1 + Len(sFrom)))
nPosAfter = nPos2 - 1
End If
GetStringBetweenTags = sFound
End Function
Public Function Global_GetCommandOutput(sCommandLine As String, Optional blnStdOut As Boolean = True, Optional blnStdErr As Boolean = False, Optional blnOEMConvert As Boolean = True) As String
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 02/09/2016
' * Time : 11:34
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Global_GetCommandOutput
' * Purpose :
' * Parameters :
' * sCommandLine As String
' * Optional blnStdOut As Boolean = True
' * Optional blnStdErr As Boolean = False
' * Optional blnOEMConvert As Boolean = True
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' Function Global_GetCommandOutput
'
' sCommandLine: [in] Command line to launch
' blnStdOut [in,opt] True (defualt) to capture output to STDOUT
' blnStdErr [in,opt] True to capture output to STDERR. False is default.
' blnOEMConvert: [in,opt] True (default) to convert DOS characters to Windows, False to skip conversion
'
' Returns: String with STDOUT and/or STDERR output
'
Dim hPipeRead As Long
Dim hPipeWrite1 As Long
Dim hPipeWrite2 As Long
Dim hCurProcess As Long
Dim sa As SECURITY_ATTRIBUTES
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
Dim baOutput() As Byte
Dim sNewOutput As String
Dim lBytesRead As Long
Dim fTwoHandles As Boolean
Const BUFSIZE = 1024 ' pipe buffer size
' *** At least one of them should be True, otherwise there's no point in calling the function
If (Not blnStdOut) And (Not blnStdErr) Then
Err.Raise 5 ' Invalid Procedure call or Argument
End If
' *** If both are true, we need two write handles. If not, one is enough.
fTwoHandles = blnStdOut And blnStdErr
ReDim baOutput(BUFSIZE - 1) As Byte
With sa
.nLength = Len(sa)
.bInheritHandle = 1 ' get inheritable pipe handles
End With
If CreatePipe(hPipeRead, hPipeWrite1, sa, BUFSIZE) = 0 Then
Exit Function
End If
hCurProcess = GetCurrentProcess()
' *** Replace our inheritable read handle with an non-inheritable. Not that it
' *** seems to be necessary in this case, but the docs say we should.
Call DuplicateHandle(hCurProcess, hPipeRead, hCurProcess, hPipeRead, 0&, 0&, DUPLICATE_SAME_ACCESS Or DUPLICATE_CLOSE_SOURCE)
' *** If both STDOUT and STDERR should be redirected, get an extra handle.
If fTwoHandles Then
Call DuplicateHandle(hCurProcess, hPipeWrite1, hCurProcess, hPipeWrite2, 0&, 1&, DUPLICATE_SAME_ACCESS)
End If
With si
.CB = Len(si)
.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
.wShowWindow = SW_HIDE ' hide the window
If fTwoHandles Then
.hStdOutput = hPipeWrite1
.hStdError = hPipeWrite2
ElseIf blnStdOut Then
.hStdOutput = hPipeWrite1
Else
.hStdError = hPipeWrite1
End If
End With
If CreateProcess(vbNullString, sCommandLine, ByVal 0&, ByVal 0&, 1, 0&, ByVal 0&, vbNullString, si, pi) Then
' *** Close thread handle - we don't need it
Call CloseHandle(pi.hThread)
' *** Also close our handle(s) to the write end of the pipe. This is important, since
' *** ReadFile will *not* return until all write handles are closed or the buffer is full.
Call CloseHandle(hPipeWrite1)
hPipeWrite1 = 0
If hPipeWrite2 Then
Call CloseHandle(hPipeWrite2)
hPipeWrite2 = 0
End If
Do
' *** Add a FauxDoEvents to allow more data to be written to the buffer for each call.
' *** This results in fewer, larger chunks to be read.
'FauxDoEvents
If ReadFile(hPipeRead, baOutput(0), BUFSIZE, lBytesRead, ByVal 0&) = 0 Then
Exit Do
End If
If blnOEMConvert Then
' *** convert from "DOS" to "Windows" characters
sNewOutput = String$(lBytesRead, 0)
Call OemToCharBuff(baOutput(0), sNewOutput, lBytesRead)
Else
' *** perform no conversion (except to Unicode)
sNewOutput = Left$(StrConv(baOutput(), vbUnicode), lBytesRead)
End If
Global_GetCommandOutput = Global_GetCommandOutput & sNewOutput
' *** If you are executing an application that outputs data during a long time,
' *** and don't want to lock up your application, it might be a better idea to
' *** wrap this code in a class module in an ActiveX EXE and execute it asynchronously.
' *** Then you can raise an event here each time more data is available.
'RaiseEvent OutputAvailabele(sNewOutput)
Loop
' When the process terminates successfully, Err.LastDllError will be
' ERROR_BROKEN_PIPE (109). Other values indicates an error.
Call CloseHandle(pi.hProcess)
Else
Global_GetCommandOutput = "Failed to create process, check the path of the command line."
End If
' *** Clean up
Call CloseHandle(hPipeRead)
If hPipeWrite1 Then
Call CloseHandle(hPipeWrite1)
End If
If hPipeWrite2 Then
Call CloseHandle(hPipeWrite2)
End If
End Function
Public Sub Global_RetrieveBarCode(sFile As String, colCodeBar As Collection)
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 02/09/2016
' * Time : 11:35
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Global_RetrieveBarCode
' * Purpose :
' * Parameters :
' * sFile As String
' * colCodeBar As Collection
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_Global_RetrieveBarCode
Dim sCallCmd As String
Dim sReturn As String
Dim sCodeBar As String
Dim nPos As Long
Dim sPathzxing As String
sPathzxing = App.Path & "\zx.exe"
sCallCmd = sPathzxing & " " & sFile '& " --try_harder"
sReturn = Global_GetCommandOutput(sCallCmd)
sReturn = Replace(sReturn, vbCr, " ")
sReturn = Replace(sReturn, vbLf, " ")
If LenB(sReturn) Then
sCodeBar = Trim$(GetStringBetweenTags(sReturn, "Raw result:", "Parsed result:", nPos))
Do While LenB(sCodeBar) > 0
colCodeBar.Add sCodeBar
sCodeBar = Trim$(GetStringBetweenTags(sReturn, "Raw result:", "Parsed result:", nPos, nPos))
Loop
End If
EXIT_Global_RetrieveBarCode:
Exit Sub
' #VBIDEUtilsERROR#
ERROR_Global_RetrieveBarCode:
Resume EXIT_Global_RetrieveBarCode
End Sub
Private Sub Command1_Click()
' #VBIDEUtils#************************************************************
' * Author :
' * Web Site :
' * E-Mail :
' * Date : 01/24/2024
' * Time : 13:59
' * Module Name : Form1
' * Module Filename : Form1.frm
' * Procedure Name : Command1_Click
' * Purpose :
' * Parameters :
' * Purpose :
' **********************************************************************
' * Comments :
' *
' *
' * Example :
' *
' * See Also :
' *
' * History :
' *
' *
' **********************************************************************
' #VBIDEUtilsERROR#
On Error GoTo ERROR_Command1_Click
Dim sFile As String
Dim oCollection As New Collection
Dim nI As Long
sFile = App.Path & "\barcode.png"
Call Global_RetrieveBarCode(sFile, oCollection)
sFile = App.Path & "\qrcode.png"
Call Global_RetrieveBarCode(sFile, oCollection)
For nI = 1 To oCollection.Count
List1.AddItem sFile & " : " & oCollection.Item(nI)
Next
EXIT_Command1_Click:
On Error Resume Next
Exit Sub
' #VBIDEUtilsERROR#
ERROR_Command1_Click:
Resume EXIT_Command1_Click
End SubNB : If some of you request, I have code to analyse Payconiq QRCode, generation of Payconiq QRCode etc...