Espero ajudar vcs com esse codigo aki...
Option Explicit
Dim nossonumero As String
Dim codigobarras As String
Dim linhadigitavel As String
Dim sql As String
Private Function Monta_CodBarras(Banco As String, Moeda As String, valor As Single, vencimento As Date, Livre As String)
Dim codigo_sequencia As String
Dim database As Date
Dim fator As Integer
Dim intDac As Integer
'database para calculo do fator
database = CDate("7/10/1997")
fator = DateDiff("d", database, Format(vencimento, "dd/mm/yyyy"))
valor = Int(valor * 100)
Livre = Format(Livre, "0000000000000000000000000")
' sequencia sem o DV
codigo_sequencia = Banco & Moeda & fator & Format(valor, "0000000000") & Livre
' calculo do DV do codigo de barras
intDac = calcula_DV_CodBarras(codigo_sequencia)
' monta a sequencia para o codigo de barras com o DV
Monta_CodBarras = (Left(codigo_sequencia, 4) & intDac & Right(codigo_sequencia, 39))
' monta sequencia da linha digitavel com os dvs
linhadigitavel = Linha_Digitavel(txtnumeroBanco & "9" & txtNumeroConvenio & nossonumero, CStr(intDac), CCur(text3(7)))
End Function
Private Sub cmdgeracodigos_Click()
'calculo do nosso numero
nossonumero = Calculo_NossoNumero(txtNumeroConvenio)
'calculo do codigo de barras
codigobarras = Monta_CodBarras(txtnumeroBanco, "9", CCur(text3(7)), CDate(text3(5)), txtNumeroConvenio & nossonumero & "21")
text3(8).Text = codigobarras
text3(9).Text = linhadigitavel
End Sub
Private Sub cmdimprimir_Click()
cr1.DataFiles(0) = App.Path & "oleto2001.mdb"
cr1.WindowState = 2
cr1.WindowControlBox = True
cr1.ReportFileName = App.Path & "oleto.rpt"
cr1.Destination = 0
cr1.Action = 1
End Sub
Private Sub Command2_Click(Index As Integer)
Select Case Index
Case 0 ' inclui
Data1.Recordset.AddNew
text3(0).SetFocus
Command2(2).Enabled = True
Command2(1).Enabled = False
Case 1 ' exclui
Data1.Recordset.Delete
Data1.Recordset.MovePrevious
Case 2 ' grava
Data1.Recordset.Update
Command2(2).Enabled = False
Command2(1).Enabled = True
Case 3 ' sai
Unload Me
End Select
End Sub
Private Function calcula_DV_CodBarras(sequencia As String) As Integer
Dim intcontador, intnumero, intTotalNumero As Integer
Dim intMultiplicador, intResto, intresultado As Integer
Dim caracter As String
intMultiplicador = 2
For intcontador = 1 To 43
caracter = Mid(Right(sequencia, intcontador), 1, 1)
If intMultiplicador > 9 Then
intMultiplicador = 2
intnumero = 0
End If
intnumero = caracter * intMultiplicador
intTotalNumero = intTotalNumero + intnumero
intMultiplicador = intMultiplicador + 1
Next
intResto = intTotalNumero Mod 11
intresultado = 11 - intResto
If intresultado = 10 Or intresultado = 11 Then
calcula_DV_CodBarras = 1
Else
calcula_DV_CodBarras = intresultado
End If
End Function
Function Linha_Digitavel(sequencia As String, DV_CodBarras As String, valor As Single) As String
Dim seq1 As String
Dim seq2 As String
Dim seq3 As String
Dim dv1, dv2, dv3 As Integer
'separa a sequencia e prepara o valor
seq1 = Left(sequencia, 9)
seq2 = Mid(sequencia, 10, 10)
seq3 = Right(sequencia, 10)
valor = Int(valor * 100)
' calcula os dvs
dv1 = Val(Calculo_DV10(seq1))
dv2 = Val(Calculo_DV10(seq2))
dv3 = Val(Calculo_DV10(seq3))
'formata a sequencia
seq1 = Left(seq1 & dv1, 5) & "." & Right(seq1 & dv1, 5)
seq2 = Left(seq2 & dv2, 5) & "." & Right(seq2 & dv2, 6)
seq3 = Left(seq3 & dv3, 5) & "." & Right(seq3 & dv3, 6)
Linha_Digitavel = seq1 & " " & seq2 & " " & seq3 & " " & DV_CodBarras & " " & valor
End Function
Function Calculo_DV10(strNumero As String) As String
'declara As variáveis
Dim intcontador, intnumero, intTotalNumero, intMultiplicador, intResto As Integer
' se nao for um valor numerico sai da função
If Not IsNumeric(strNumero) Then
Calculo_DV10 = ""
Exit Function
End If
'inicia o multiplicador
intMultiplicador = 2
'pega cada caracter do numero a partir da direita
For intcontador = Len(strNumero) To 1 Step -1
'extrai o caracter e multiplica prlo multiplicador
intnumero = Val(Mid(strNumero, intcontador, 1)) * intMultiplicador
' se o resultado for maior que nove soma os algarismos do resultado
If intnumero > 9 Then
intnumero = Val(Left(intnumero, 1)) + Val(Right(intnumero, 1))
End If
'soma o resultado para totalização
intTotalNumero = intTotalNumero + intnumero
'se o multiplicador for igual a 2 atribuir valor 1 se for 1 atribui 2
intMultiplicador = IIf(intMultiplicador = 2, 1, 2)
Next
'calcula o resto da divisao do total por 10
intResto = intTotalNumero Mod 10
'verifica as exceções ( 0 -> DV=0 )
Select Case intResto
Case 0
Calculo_DV10 = "0"
Case Else
Calculo_DV10 = Str(intResto)
End Select
End Function
Function Calculo_DV11(strNumero As String) As String
'declara as variáveis
Dim intcontador, intnumero, intTotalNumero, intMultiplicador, intResto As Integer
' se nao for um valor numerico sai da função
If Not IsNumeric(strNumero) Then
Calculo_DV11 = ""
Exit Function
End If
'inicia o multiplicador
intMultiplicador = 9
'pega cada caracter do numero a partir da direita
For intcontador = Len(strNumero) To 1 Step -1
'extrai o caracter e multiplica prlo multiplicador
intnumero = Val(Mid(strNumero, intcontador, 1)) * intMultiplicador
'soma o resultado para totalização
intTotalNumero = intTotalNumero + intnumero
'se o multiplicador for maior que 2 decrementa-o caso contrario atribuir valor padrao original
intMultiplicador = IIf(intMultiplicador > 2, intMultiplicador - 1, 9)
Next
'calcula o resto da divisao do total por 11
intResto = intTotalNumero Mod 11
'verifica as exceções ( 0 -> DV=0 10 -> DV=X (para o BB) e retorna o DV
Select Case intResto
Case 0
Calculo_DV11 = "0"
Case 10
Calculo_DV11 = "X"
Case Else
Calculo_DV11 = Str(intResto)
End Select
End Function
Function Calculo_NossoNumero(sequencia As String) As String
'montamos o nosso numero com o numero do convenio ( 6 posicoes)
Dim dv As Integer
dv = Calculo_DV11(sequencia)
Calculo_NossoNumero = Format(sequencia & dv, "00000000000000000")
End Function
Private Sub limpa_registros()
Dim i As Integer
For i = 0 To 7
text3(i).Text = ""
Next
txtBoletoID.Text = ""
End Sub
Private Sub Command3_Click()
Data2.Recordset.AddNew
End Sub
Private Sub Command4_Click()
Data2.Recordset.Delete
Data2.Recordset.MovePrevious
End Sub
Private Sub Command5_Click()
Data2.Recordset.Update
End Sub
Private Sub Form_Load()
Command2(2).Enabled = False
End Sub
