'VARIÁVEIS PARA O CÓDIGO DE BARRAS
Public GRCODBAR As String '44 P. CODIGO DA BARRA
Public GRCBOXES As String '48 P. CODIGO / LINHA DIGITAVEL
Public GRVVALOR As Currency '11 DIGITOS 'VALOR TOTAL DO CODIGO
'Valor: 55,00
Public GRIDENTI As String '4 DIGITOS 'CONVENIO
'0000
Public GRCODCON As String '13 DIGITOS 'CODIGO DO CONTRIBUINTE
'Contribuinte: 100.002.0003.004
Public GRCODPAR As String '2 DIGITOS 'CODIGO DA PARCELA
'Parcela: 01
Public GRDATAVE As String '8 DIGITOS 'DATA DE VENCIMENTO
Public GA As String
Public GB As String
Public GC As String
'DataVencimento: 03/04/2004
'Public GRCBANCO As String '3 DIGITOS 'BANCO
'Banco: 031
'Public GRAGENCI As String '4 DIGITOS 'AGENCIA
'Agencia: 114
'-------------------------CODIGO PRONTO---------------------------
'OBRIGATORIO VALOR CONVENIO SEUS DADOS
'8165 00000009211 0173 8772200303310110780867000
'18 + O DIGITO GERAL
'ANTES DE FICAR PRONTO ELE FICA ASSIM-----------------------------
'816000000092110173 8772200303310110780867000
'VC TEM 25 DIGITOS PARA SEU USO. POR ISSO O BANCO A AGENCIA NAO PODERA IR JUNTO
'VOU ACRESCENTAR 2 ZEROS A ESQUERDA DO CONTRIBUINTE - LEMBRE-SE DISSO NA HORA DE BAIXAR
'OBS.: TODOS OS DADOS ACIMA DEVERAO SER TRATADOS, OU SEJA ELES SO VEM PARA
' AS VARIAVEIS COM O SEU VALOR FINAL - SOMENTE NUMEROS
'CODIGO BARRAS..............................................................................
Public Function CODBAR()
'GRIDENTI = "0137" 'CÓDIGO DO CONVENIO - DEIXE AQUI O NUMERO DO CONVENIO
Dim GD As String
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
Dim box1, box2, box3, box4 As String
Dim XDG, XD1, XD2, XD3, XD4 As String
GA = "8" 'MUDE AQUI PARA O PADRAO QUE A FEBRABAN TE PASSOU
GB = "1" 'CADA UM DESSES NUMEROS TEM UM SIGNIFICADO
GC = "6" 'ESSES TAMBEM SAO FIXOS
GCENTS = GRVVALOR - Int(GRVVALOR)
If Len(GCENTS) = 1 Then GCENTS = "00"
If Len(GCENTS) = 3 Then GCENTS = Right(GCENTS, 1) & "0"
If Len(GCENTS) = 4 Then GCENTS = Right(GCENTS, 2)
GE = "00" & GCENTS & Int(GRVVALOR)
GE = "00" & Right(1000000000 + Int(GE), 9)
GF = GRIDENTI
GRDATAVE = "00" & GRDATAVE
GG = GRDATAVE & GRCODPAR & GRCODCON
GCOD = GA & GB & GC & GE & GF & GG
TEXTOSIM = GCOD
XDG = Left(TEXTOSIM, 4): XDG = Right(XDG, 1) 'digito geral
TEXTOSIM = Left(TEXTOSIM, 3) & Right(TEXTOSIM, 40) 'sem o digito geral
box1 = Left(GCOD, 10)
box2 = Left(GCOD, 21): box2 = Right(box2, 11)
box3 = Left(GCOD, 32): box3 = Right(box3, 11)
box4 = Right(GCOD, 11)
'VERIFICAMDO O DIGITO GERAL
Dim posi, soma, mulp As Double 'posicao do digito
Dim Cont As String
Dim somg As Double
Dim ACAO, condicao As Double
posi = 0 'posicao do texto
soma = 0 'soma o conteudo da posicao e multiplica pelo multi
somg = 0 'soma geral
mulp = 2 'multiplicador 2ou1
ACAO = 0: condicao = 0
Do While ACAO < 5
ACAO = ACAO + 1
condicao = 11
If ACAO = 1 Then condicao = 43 'VERIFICA O DIGITO GERAL
If ACAO = 2 Then TEXTOSIM = Left(box1, 3) & XDG & Right(box1, 7) ' MsgBox Len(TEXTOSIM) 'VERIFICA O DIGITO 1 BOX
If ACAO = 3 Then TEXTOSIM = box2 ' MsgBox TEXTOSIM 'VERIFICA O DIGITO 2 BOX
If ACAO = 4 Then TEXTOSIM = box3 ' MsgBox TEXTOSIM 'VERIFICA O DIGITO 3 BOX
If ACAO = 5 Then TEXTOSIM = box4 ' MsgBox TEXTOSIM 'VERIFICA O DIGITO 4 BOX
posi = 0 'posicao do texto
soma = 0 'soma o conteudo da posicao e multiplica pelo multi
somg = 0 'soma geral
mulp = 2 'multiplicador 2ou1
Do While posi < condicao
posi = posi + 1
Cont = Left(TEXTOSIM, posi): Cont = Right(Cont, 1)
soma = Val(Cont) * mulp
If soma >= 10 Then
xsom = soma
somg = somg + Val(Left(xsom, 1)) + Val(Right(xsom, 1))
soma = Val(Left(xsom, 1)) + Val(Right(xsom, 1))
Else
somg = somg + soma
End If
If mulp = 2 Then
mulp = 1
Else
mulp = 2
End If
Loop
If somg > 10 Then
a = somg / 10 ' divisao
b = Int(a) * 10 ' multiplicando para chegar ao resultado
c = somg - b ' achando o resto
If c > 0 Then
somg = 10 - c
Else
somg = 0
End If
Else
somg = 10 - somg
End If
If ACAO = 1 Then 'ACAO -ACHANDO O DIGITO GERAL
XDG = somg
GRCODBAR = Left(box1, 3) & XDG & Right(box1, 7) & box2 & box3 & box4
End If
If ACAO = 2 Then 'ACAO -ACHANDO O DIGITO 1 BOX
box1 = Left(GCOD, 10)
box1 = Left(box1, 3) & XDG & Right(box1, 7) & " " & somg
End If
If ACAO = 3 Then 'ACAO -ACHANDO O DIGITO 2 BOX
box2 = box2 & " " & somg
End If
If ACAO = 4 Then 'ACAO -ACHANDO O DIGITO 3 BOX
box3 = box3 & " " & somg
End If
If ACAO = 5 Then 'ACAO -ACHANDO O DIGITO 4 BOX
box4 = box4 & " " & somg
End If
DoEvents
Loop
GRCBOXES = box1 & " " & box2 & " " & box3 & " " & box4
End Function
funcao no form:
'calculo o valor da parcela unica
Dim CodUnica As String
Dim ParUnica As String
Dim datUnica As String
Dim valorUnica As String
CodUnica = ""
ParUnica = ""
valorUnica = "0"
CodUnica = Format(TabelaPag("CodContribuinte"), "") 'valor do codigo do contribuinte
ParUnica = "00" 'valor para parcela unica
datUnica = Format(TabelaPag("DatParcUnica"), "yyyymmdd") 'valor da data da parcela
valorUnica = Replace(TabelaPag("ValParcUnica"), ",", "") 'valor da parcela unica
'funcao para o codigo de barras
GRCODCON = CodUnica 'CONTRIBUINTE
GRCODPAR = ParUnica 'PARCELA
GRDATAVE = datUnica 'VENCIMENTO
GRVVALOR = valorUnica 'VALOR - ESSE CAMPO NAO PRECISA DE TRATAMENTO
GRIDENTI = Seg & Conv
CODBAR 'GERA O CODIGO
esse codigo acima pegar os seguinte valores para gerar os numeros:
inscricao 100.001.0001.000
data venc. 15/03/2005
valor: 1325,25
parcela: 00 (unica)
que ficar assim:
81610001325254811370020050315001000010001000
como faço para que o codigo fique assim:
8161000132525 48113700 20050315 00 1000010001000
veja que onde é para ficar o valor ele termina na posicao 13 e era pra terminar na 15..
da onde saiu esse 48?
finalizando eu queria ele assim:
81610000013252500113720050315001000010001000
8161 00000132525 001137 20050315 00 1000010001000
ou seja:
numero do codigo: 8161
campo do valor: 00000132525
numero de identificacao: 001137
campo da data: 20050315
campo da parcela: 00
campo da inscricao do contribuinte: 1000010001000
esse sistema é de IPTU.
alguem poderia me ajudar a concertar isso, e que ele fique no padrao da febraban?
grato pela atencao.
