Pronto para ser enviado, mas seu e-mail, não aceitou, poste aqui, que enviarei.
Veja se aqui serve:
VEJA SE VOCE ENTENDE, AQUI PEGA OS VALORES DE UMA TABELA,
CONVERTE EM CÓDIGO DE BARRAS E IMPRIME NO OBJETO PRINTER
Option Explicit
Dim AMDB As Database
Dim rtIMPR As Recordset
Dim sBOOKMARK As String
Dim sCODBARRA As String
Dim sBARRA As String
Dim suBARRA As String
Dim sCODIGO As String
Dim sVALOR As String
Dim sU As String
Dim sVCTO As String
Dim sDIGITO As String
Dim sDG As String
Dim sDGV As String
Dim sDG1 As String
Dim sDG2 As String
Dim sDG3 As String
Dim sDG4 As String
Dim cVALOR As Currency
Dim dVCTO As Date
Private Function VAI()
Dim iFONTSIZE As Integer
Dim sOLDFONT As String
Dim sVALO As String
Dim iTAM As Integer
Dim cuVL As Currency
Dim iCOPIA As Integer
Dim iuCOPIA As Integer
Dim I As Integer
Dim iLI As Integer
Dim iVALUE As Long
Dim dDTA As Date
Dim dUDTA As Date
Dim dVCTODESC As Date
MousePointer = 11
Set AMDB = OpenDatabase(sAMDB) ' nome do banco definido em uma variavel
Set rtIMPR = AMDB.OpenRecordset("IMPR", dbOpenTable)
sOLDFONT = Printer.FontName
iFONTSIZE = Printer.FontSize
Printer.ScaleMode = vbCharacters
Printer.ScaleTop = 0
Printer.ScaleLeft = 0
Printer.CurrentX = 0
Printer.CurrentY = 0
If rtIMPR.RecordCount > 0 Then
rtIMPR.MoveMin ' aqui vai p/ o inicio da tabela
iCOPIA = 1
iuCOPIA = 2
Do While Not rtIMPR.EOF
dVCTO = rtIMPR!VCTO ' AQUI A DATA DE VENCIMENTO DO BOLETO
dDTA = Format(Date, "dd/mm/yyyy")
sBOOKMARK = rtIMPR.Bookmark ' AQUI MARCA O REGISTRO
CALCULA ' aqui forma o código de barra
sBARRA = CONVERTE2OF5(txtCODIGO.Text) ' AQUI CONVERTE EM BARRAS P/ IMPRIMIR
txtCODIGO.Text = sBARRA
For iCOPIA = 1 To iuCOPIA
Printer.FontName = "Verdana"
Printer.FontName = "Interleaved 2of5 NT"
Printer.FontSize = 14
Printer.FontBold = False
For I = 0 To 3
Printer.Print Tab(1); " " & sBARRA ' AQUI A IMPRESSÃO DO CÓDIGO DE BARRAS
Next
Printer.CurrentX = 0
Printer.FontName = "Verdana"
Printer.FontBold = False
Printer.FontSize = 6
Printer.Print Tab(33); lblCODIGO.Caption
' o restante são os dados do boleto
' nesta área
Printer.Print Tab(20); "NÃO RECEBER APÓS O VENCIMENTO"
Printer.FontSize = 8
Printer.Print Tab(10); " Local de Pagamento: Banco do Brasil S/A"
If iCOPIA = 1 Then
Printer.Print Tab(30); " Via do Orgão Arrecadador"
Else
Printer.Print Tab(30); " Via do Contribuinte"
End If
Printer.Print Tab(10); "----------------------------------------------------------------------------------------------------------------------------------"
Printer.Print
Printer.FontBold = False
Next iCOPIA
Printer.NewPage
rtIMPR.MoveNext
Loop
Printer.FontName = sOLDFONT
Printer.FontSize = iFONTSIZE
Printer.EndDoc
End If
rtIMPR.Close
AMDB.Close
MousePointer = 0
Beep
sMEN = MsgBox("IPTU(s) Impressos. Aguarde Saída na Impressora", vbInformation + vbOKOnly, "Impressão de IPtu(S)")
Exit Function
End Function
'FUNÇÃO QUE FORMA A BARRA
Private Function CALCULA()
sCODIGO = ""
sBARRA = ""
sU = ""
rtIMPR.Bookmark = sBOOKMARK
sCODIGO = sIDENTPROD & sIDENTSEG & sMOEDA
sU = Format$(((rtIMPR!PARCELA + rtIMPR!JUROS) - rtIMPR!DESCONTO), "000000000.00")
sVALOR = Left(sU, 9) & Right(sU, 2)
sCODIGO = sCODIGO & sVALOR & sIDENTEMPRESA
sVCTO = "0000" & Trim(Str(Trim(Year(Format$(rtIMPR!VCTO, "dd/mm/yyyy")))))
sVCTO = Right(sVCTO, 4)
sU = "00" & Trim(Str(Trim(Month(Format$(rtIMPR!VCTO, "dd/mm/yyyy")))))
sU = Right(sU, 2)
sVCTO = sVCTO & sU
sU = "00" & Trim(Str(Trim(Day(Format$(rtIMPR!VCTO, "dd/mm/yyyy")))))
sU = Right(sU, 2)
sVCTO = sVCTO & sU
sDIGITO = rtIMPR!BARRA
If sDIGITO = "UN" Then
sDIGITO = "0101"
Else
sDIGITO = sDIGITO & rtIMPR!DIGITO
End If
sCODIGO = sCODIGO & sVCTO & rtIMPR!CODIMOV & sDIGITO & rtIMPR!ANO
sDGV = ""
DIGITOV
sBARRA = Left(sCODIGO, 3) & sDGV & Right(sCODIGO, 40)
sCODIGO = sBARRA
txtCODIGO.Text = sBARRA
sDG1 = ""
suBARRA = Left(sBARRA, 11)
DIGITO
sDG1 = sDG
suBARRA = Mid(sBARRA, 12, 11)
DIGITO
sDG2 = sDG
suBARRA = Mid(sBARRA, 23, 11)
DIGITO
sDG3 = sDG
suBARRA = Right(sBARRA, 11)
DIGITO
sDG4 = sDG
sCODIGO = Left(sBARRA, 11) & " " & sDG1 & " "
sCODIGO = sCODIGO & Mid(sBARRA, 12, 11) & " " & sDG2 & " "
sCODIGO = sCODIGO & Mid(sBARRA, 23, 11) & " " & sDG3 & " "
sCODIGO = sCODIGO & Mid(sBARRA, 34, 11) & " " & sDG4
lblCODIGO.Caption = sCODIGO
Exit Function
End Function
' FUNÇÃO QUE COLOCA OS DIGITOS
Private Function DIGITOV()
Dim iuTAM As Integer
Dim iTAM As Integer
Dim I As Integer
Dim iU As Integer
Dim cSOMA As Currency
Dim cuSOMA As Currency
Dim iNUM As Integer
Dim iVEZES As Integer
Dim iRESULT As Integer
iTAM = Len(Trim(sCODIGO))
cSOMA = 0
iuTAM = 0
iVEZES = 1
For I = iTAM To 1 Step -1
iNUM = Val(Mid(sCODIGO, I, 1))
If iVEZES = 1 Then
iVEZES = 2
Else
iVEZES = 1
End If
cuSOMA = (iNUM * iVEZES)
iuTAM = Len(Trim(Str(Trim(cuSOMA))))
For iU = 1 To iuTAM
cSOMA = cSOMA + Mid(cuSOMA, iU, 1)
Next
Next
iRESULT = Int(cSOMA / 10)
sDGV = Trim(Str(Trim((Int(cSOMA - (iRESULT * 10))))))
If sDGV <> "0" Then
sDGV = Trim(Str(Trim(10 - Val(sDGV))))
End If
Exit Function
End Function
Private Function DIGITO()
Dim iuTAM As Integer
Dim I As Integer
Dim iU As Integer
Dim cSOMA As Currency
Dim cuSOMA As Currency
Dim iNUM As Integer
Dim iVEZES As Integer
Dim iRESULT As Integer
cSOMA = 0
iuTAM = 0
iVEZES = 1
For I = 11 To 1 Step -1
iNUM = Val(Mid(suBARRA, I, 1))
If iVEZES = 1 Then
iVEZES = 2
Else
iVEZES = 1
End If
cuSOMA = (iNUM * iVEZES)
iuTAM = Len(Trim(Str(Trim(cuSOMA))))
For iU = 1 To iuTAM
cSOMA = cSOMA + Mid(cuSOMA, iU, 1)
Next
Next
iRESULT = Int(cSOMA / 10)
sDG = Trim(Str(Trim((Int(cSOMA - (iRESULT * 10))))))
If sDG <> "0" Then
sDG = Trim(Str(Trim(10 - Val(sDG))))
End If
Exit Function
End Function
' FUNÇÃO QUE CONVERTE NA FONTE PARA IMPRIMIR
Private Function CONVERTE2OF5(sVValor As String) As String
Dim VVetor(0 To 99) As String
Dim I As Integer
Dim iV2digitos As Integer
Dim sVValorCodificado As String
Dim sStart As String
Dim sStop As String
'--- define o start e stop para a simbologia i2of5
sStart = Chr(40)
sStop = Chr(41)
'--- preenche o vetor com os caracteres equivalentes.
'--- onde :
'--- índice do vetor => valor inteiro
'--- conteúdo do vetor => valor codificado (caracter)
'--- existe uma fórmula matemática para converter esses dados
'--- porém, desta forma que desenvolvi torna-se muito mais simples.
iV2digitos = 0
For I = 48 To 97
VVetor(iV2digitos) = Chr(I)
iV2digitos = iV2digitos + 1
Next
For I = 192 To 241
VVetor(iV2digitos) = Chr(I)
iV2digitos = iV2digitos + 1
Next
'--- codifica o valor numérico em i2of5
sVValorCodificado = ""
For I = 1 To Len(sVValor) Step 2
iV2digitos = Val(Mid(sVValor, I, 2))
sVValorCodificado = sVValorCodificado & VVetor(iV2digitos)
Next
'--- retorna o valor codificado, pronto para imprimir
'--- a simbologia interleaved 2of5 (no fonte apropriado)
CONVERTE2OF5 = sStart & sVValorCodificado & sStop
End Function
Esta conversão recebi de um amigo do forum.
Espero que entenda.
Ramos
vlu//
