|
|
|
|
|
|
|
|
Dicas
|
|
|
Visual Basic (Miscelâneas)
|
|
 |
Título da Dica: Rotina pronta para gerar a linha digitável do código de barras Padrão FEBRABAN
|
 |
|
|
|
Postada em 13/2/2004 por Ebytes
Segue rotina que gera o código de barras padrão FEBRABAN. Basta copiar a função para o seu código e declarar as variáveis públicas:
Public GRCODBAR As String 'CÓDIGO DE BARRAS SEM DÍGITOS
Public GRCBOXES As String 'CÓDIGO COM OS DÍGITOS OU SEJA A BARRA
Public GRVVALOR As Currency 'VALOR TOTAL
Public GRIDENTI As String 'CÓDIGO DO CONVENIO ENTRE A FEBRABAN E A EMPRESA - OBRIGATÓRIO
Public GRSEMUSO As String 'CAMPO LIVRE
Public GRCODRUA As String 'CAMPO LIVRE
Public GRCODCON As String 'CAMPO LIVRE
Public GRREFERE As String 'CAMPO LIVRE
Public GRVARIAC As String 'CAMPO LIVRE
Public GRCBTIPO As String 'CAMPO LIVRE
Public Function CODBAR()
'GRIDENTI = "0000" 'CÓDIGO DO CONVENIO ENTRE A FEBRABAN E A EMPRESA - OBRIGATÓRIO
'GRVVALOR = "24,00" 'VALOR TOTAL DO CÓDIGO
'GRSEMUSO = "00000" 'A SEU CRITÉRIO - SE QUIZER MUDE ESSAS VARIÁVIES
'GRCODRUA = "001" 'A SEU CRITÉRIO - "" ""
'GRCODCON = "00001" 'A SEU CRITÉRIO - "" ""
'GRREFERE = "10/2003" 'A SEU CRITÉRIO - "" ""
'GRVARIAC = "00001" 'A SEU CRITÉRIO - "" ""
'GRCBTIPO = "2" 'A SEU CRITÉRIO - SE QUIZER MUDE ESSAS VARIÁVIES
Dim GA As String
Dim GB As String
Dim GC As String
Dim GD As String 'DÍGITO VERIFICADOR DO CÓDIGO (GERAL)
Dim GE As String
Dim GF As String
Dim GG As String
Dim GCOD As String
Dim goma As Double
Dim g1 As Double
Dim g2 As Double
Dim gdig As Double
Dim pos As Double
Dim GRVIGGGG As Double
GA = "8"
GB = "2"
GC = "6"
GCENTS = GRVVALOR - Int(GRVVALOR)
If GCENTS <> 0 Then
GE = Right(1000000000 + Int(GRVVALOR), 9) & Right(GRVVALOR, 2)
Else
GE = Right(1000000000 + Int(GRVVALOR), 9) & "00"
End If
GF = GRIDENTI
GG = GRSEMUSO & GRCODRUA & GRCODCON & Left(GRREFERE, 2) & Right(GRREFERE, 4) & GRVARIAC & GRCBTIPO
GCOD = GA & GB & GC & GE & GF & GG
' DÍGITO VERIRICADOR DO CÓDIGO DE BARRAS
pos = 43
GSOMA = 0
Do While True
If pos >= 1 Then
g1A = Left(GCOD, pos)
g1B = Val(Right(g1A, 1))
g1 = g1B * 2
If pos >= 1 Then
pos = pos - 1
End If
If g1 > 9 Then
g1 = Val(Left(g1, 1)) + Val(Right(g1, 1))
Else
g1 = g1
End If
GSOMA = GSOMA + g1
End If
If pos >= 1 Then
g2A = Left(GCOD, pos)
g2B = Val(Right(g2A, 1))
g2 = g2B * 1
If pos >= 1 Then
pos = pos - 1
End If
If g2 > 9 Then
g2 = Val(Left(g2, 1)) + Val(Right(g2, 1))
Else
g2 = g2
End If
GSOMA = GSOMA + g2
End If
If pos < 1 Then
Exit Do
End If
Loop
If GSOMA <= 10 Then
gdig = 0
Else
gdiv = GSOMA / 10
gpro = Int(gdiv) * 10
gres = GSOMA - gpro
If gres = 0 Then
gdig = 0
Else
gdig = 10 - gres
End If
End If
'NÚMEROS DO CÓDIGO DE BARRAS PARA SER TRANSFORMADO EM BARRAS
GRCODBAR = Left(GCOD, 3) & gdig & Right(GCOD, 40)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'DÍGITO VERIFICADOR DO 1º BOX
b1 = Left(GRCODBAR, 11)
pos = 11
GBOX1 = ""
GSOMA = 0
Do While True
If pos >= 1 Then
g1A = Left(b1, pos)
g1B = Val(Right(g1A, 1))
g1 = g1B * 2
If pos >= 1 Then
pos = pos - 1
End If
If g1 > 9 Then
g1 = Val(Left(g1, 1)) + Val(Right(g1, 1))
Else
g1 = g1
End If
GSOMA = GSOMA + g1
End If
If pos >= 1 Then
g2A = Left(b1, pos)
g2B = Val(Right(g2A, 1))
g2 = g2B * 1
If pos >= 1 Then
pos = pos - 1
End If
If g2 > 9 Then
g2 = Val(Left(g2, 1)) + Val(Right(g2, 1))
Else
g2 = g2
End If
GSOMA = GSOMA + g2
End If
If pos < 1 Then
Exit Do
End If
Loop
If GSOMA <= 10 Then
gdig = 0
Else
gdiv = GSOMA / 10
gpro = Int(gdiv) * 10
gres = GSOMA - gpro
If gres = 0 Then
gdig = 0
Else
gdig = 10 - gres
End If
End If
GBOX1 = b1 & " " & gdig '1º BOX
''''''''''''''''''''''''''''''''''
'DÍGITO VERIFICADOR DO 2º BOX
b2 = Right(GRCODBAR, 33)
b2 = Left(b2, 11)
pos = 11
GBOX2 = ""
GSOMA = 0
Do While True
If pos >= 1 Then
g1A = Left(b2, pos)
g1B = Val(Right(g1A, 1))
g1 = g1B * 2
If pos >= 1 Then
pos = pos - 1
End If
If g1 > 9 Then
g1 = Val(Left(g1, 1)) + Val(Right(g1, 1))
Else
g1 = g1
End If
GSOMA = GSOMA + g1
End If
If pos >= 1 Then
g2A = Left(b2, pos)
g2B = Val(Right(g2A, 1))
g2 = g2B * 1
If pos >= 1 Then
pos = pos - 1
End If
If g2 > 9 Then
g2 = Val(Left(g2, 1)) + Val(Right(g2, 1))
Else
g2 = g2
End If
GSOMA = GSOMA + g2
End If
If pos < 1 Then
Exit Do
End If
Loop
If GSOMA <= 10 Then
gdig = 0
Else
gdiv = GSOMA / 10
gpro = Int(gdiv) * 10
gres = GSOMA - gpro
If gres = 0 Then
gdig = 0
Else
gdig = 10 - gres
End If
End If
GBOX2 = b2 & " " & gdig '2º BOX
''''''''''''''''''''''''''''''''''
'DÍGITO VERIFICADOR DO 3º BOX
b3 = Right(GRCODBAR, 22)
b3 = Left(b3, 11)
pos = 11
GBOX3 = ""
GSOMA = 0
Do While True
If pos >= 1 Then
g1A = Left(b3, pos)
g1B = Val(Right(g1A, 1))
g1 = g1B * 2
If pos >= 1 Then
pos = pos - 1
End If
If g1 > 9 Then
g1 = Val(Left(g1, 1)) + Val(Right(g1, 1))
Else
g1 = g1
End If
GSOMA = GSOMA + g1
End If
If pos >= 1 Then
g2A = Left(b3, pos)
g2B = Val(Right(g2A, 1))
g2 = g2B * 1
If pos >= 1 Then
pos = pos - 1
End If
If g2 > 9 Then
g2 = Val(Left(g2, 1)) + Val(Right(g2, 1))
Else
g2 = g2
End If
GSOMA = GSOMA + g2
End If
If pos < 1 Then
Exit Do
End If
Loop
If GSOMA <= 10 Then
gdig = 0
Else
gdiv = GSOMA / 10
gpro = Int(gdiv) * 10
gres = GSOMA - gpro
If gres = 0 Then
gdig = 0
Else
gdig = 10 - gres
End If
End If
GBOX3 = b3 & " " & gdig '3º BOX
''''''''''''''''''''''''''''''''''
'DÍGITO VERIFICADOR DO 4º BOX
b4 = Right(GRCODBAR, 11)
pos = 11
GBOX4 = ""
GSOMA = 0
Do While True
If pos >= 1 Then
g1A = Left(b4, pos)
g1B = Val(Right(g1A, 1))
g1 = g1B * 2
If pos >= 1 Then
pos = pos - 1
End If
If g1 > 9 Then
g1 = Val(Left(g1, 1)) + Val(Right(g1, 1))
Else
g1 = g1
End If
GSOMA = GSOMA + g1
End If
If pos >= 1 Then
g2A = Left(b4, pos)
g2B = Val(Right(g2A, 1))
g2 = g2B * 1
If pos >= 1 Then
pos = pos - 1
End If
If g2 > 9 Then
g2 = Val(Left(g2, 1)) + Val(Right(g2, 1))
Else
g2 = g2
End If
GSOMA = GSOMA + g2
End If
If pos < 1 Then
Exit Do
End If
Loop
If GSOMA <= 10 Then
gdig = 0
Else
gdiv = GSOMA / 10
gpro = Int(gdiv) * 10
gres = GSOMA - gpro
If gres = 0 Then
gdig = 0
Else
gdig = 10 - gres
End If
End If
GBOX4 = b4 & " " & gdig '4º BOX
''''''''''''''''''''''''''''''''''
'CÓDIGO DE BARRAS EM BOXES, OU SEJA A LINHA DIGITÁVEL
GRCBOXES = GBOX1 & " " & GBOX2 & " " & GBOX3 & " " & GBOX4
End Function
********* Como chamá-la??? ******* mamão com açuca!!!
iguale os valores as variávies:
GRVVALOR = "24,00"
GRVVALOR = Replace(GRVVALOR, ",", "")
GRSEMUSO = "00000"
GRCODRUA = "001"
GRCODCON = "00001"
GRREFERE = mkbREFER.Text
GRVARIAC = "00000"
GRCBTIPO = "1"
CODBAR 'aqui ela gera o código..............
Resultado:
GRCBOXES = Código completo - o que vai na barra
|
|
|
|
|
