analistasysbh

Posso postar sim, sem problemas.... Abaixo transcrevo o fonte em arquivo texto (.TXT) referente as rotinas relacionadas com o formulário de importação (frmImportar). O erro está ocorrendo na rotina: Private Sub GravaTblSada() . . . End Sub Qualquer coisa, pode me contactar em: jackson_analista@yahoo.com.br FrmImportar: Option Explicit Dim bParar As Boolean Dim linhasTxt As Long Private Sub cmdFechar_Click() Unload Me End Sub Private Function ContIniciaBarraProgressso() On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro ProgressBar1.Min = 0 ProgressBar1.Max = linhasTxt - 1 ProgressBar1.Value = 0 ProgressBar1.Visible = True Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ContIniciaBarraProgresso()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function BuscaCodClienteFiat(ByVal Numero As Long, Nome As String) As Integer ' Dim rsCliente As adodb.Recordset ' ' Set rsCliente = New adodb.Recordset ' rsCliente.Open "SELECT NumCliente FROM TblClienteFiat WHERE Nome = '" & Nome & "' AND" & CodCLiente = " & Numero & "", db, adOpenStatic, adLockOptimistic" ' ' If rsCliente.EOF Then ' db.Execute "INSERT INTO TblClienteFiat (CodCliente, Nome) VALUES ( " & Numero & ", '" & Nome & "')" ' Set rsCliente = New adodb.Recordset ' rsCliente.Open "SELECT NumCliente FROM TblClienteFiat WHERE Nome = '" & Nome & "' AND CodCLiente = " & Numero & " ", db, adOpenStatic, adLockOptimistic ' End If ' BuscaCodClienteFiat = rsCliente!NumCliente ' rsCliente.Close ' Set rsCliente = Nothing End Function Private Sub GravaTblVien(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("TipoEntrega") = ArrayGerado(1) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(2)) rsArquivo("Mes") = Mid(ArrayGerado(3), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(3), 4, 4) rsArquivo("QtdVeiculos") = IIf(ArrayGerado(4) <> "", ArrayGerado(4), 0) rsArquivo("QtdViagens") = IIf(ArrayGerado(5) <> "", ArrayGerado(5), 0) rsArquivo("QtdEntregas") = IIf(ArrayGerado(6) <> "", ArrayGerado(6), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblVien()"), Err.Description, Err.HelpFile, Err.HelpContext) End If End Sub Private Sub GravaTblVici(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) 'rsArquivo("MesAno") = Arraygerado(2) rsArquivo("Mes") = Mid(ArrayGerado(2), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(2), 4, 4) rsArquivo("CodCidade") = BuscaCodCidade(ArrayGerado(3), ArrayGerado(4)) rsArquivo("TipoEntrega") = ArrayGerado(5) rsArquivo("QtdVeiculos") = IIf(ArrayGerado(6) <> "", ArrayGerado(6), 0) rsArquivo("QtdEntregas") = IIf(ArrayGerado(7) <> "", ArrayGerado(7), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblVici()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub GravaTblSada(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew MsgBox ArrayGerado(0) rsArquivo("Chassi") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) 'Acredito que o erro esteja ocorrendo aqui rsArquivo("CodEstab") = ArrayGerado(2) 'BuscaCodEstab(ArrayGerado(2)) rsArquivo("Conhecimento") = ArrayGerado(3) VerificaCliente ArrayGerado(4) rsArquivo("CodCliente") = ArrayGerado(4) rsArquivo("DtExped") = CDate(ArrayGerado(5)) rsArquivo("NotaFiscal") = ArrayGerado(6) If ArrayGerado(7) = "" Then rsArquivo("Frota") = 99 Else VerificaFrota Replace(ArrayGerado(7), ".", "") rsArquivo("Frota") = Replace(ArrayGerado(7), ".", "") End If rsArquivo("Km") = ArrayGerado(8) If ArrayGerado(9) <> vbNullString Then rsArquivo("FreteSada") = CDbl(Replace(ArrayGerado(9), ".", ".")) + CDbl(Replace("0,00", ".", ".")) rsArquivo("CodCidade") = BuscaCodCidade(Replace(ArrayGerado(10), "'", "`"), Replace(ArrayGerado(11), "'", "`")) If ArrayGerado(12) <> vbNullString Then rsArquivo("FreteTotal") = CDbl(Replace(ArrayGerado(12), ".", ".")) + CDbl(Replace("0,00", ".", ".")) If ArrayGerado(13) <> vbNullString Then rsArquivo("ICMS") = CDbl(Replace(ArrayGerado(13), ".", ".")) + CDbl(Replace("0,00", ".", ".")) If ArrayGerado(14) <> vbNullString Then rsArquivo("Seguro") = CDbl(Replace(ArrayGerado(14), ".", ".")) + CDbl(Replace("0,00", ".", ".")) If ArrayGerado(15) <> vbNullString Then rsArquivo("Pedagio") = CDbl(Replace(ArrayGerado(15), ".", ".")) + CDbl(Replace("0,00", ".", ".")) If ArrayGerado(16) <> vbNullString Then rsArquivo("ISS") = CDbl(Replace(ArrayGerado(16), ".", ".")) + CDbl(Replace("0,00", ".", ".")) If ArrayGerado(17) <> vbNullString Then rsArquivo("Desconto") = CDbl(Replace(ArrayGerado(17), ".", ".")) + CDbl(Replace("0,00", ".", ".")) rsArquivo("CodDescricao") = BuscaCodDescricao(Replace(ArrayGerado(18), "'", "`")) rsArquivo("CodModelo") = BuscaCodModelo(Replace(ArrayGerado(19), "'", "`")) If ArrayGerado(20) <> vbNullString Then rsArquivo("VrMercadoria") = CDbl(Replace(ArrayGerado(20), ".", ".")) + CDbl(Replace("0,00", ".", ".")) If ArrayGerado(21) <> vbNullString Then rsArquivo("Pedido") = ArrayGerado(21) 'If ArrayGerado(22) > 58 And ArrayGerado(22) < 2981 Then ' MsgBox "Tipo Servico Inexistente" 'End If If ArrayGerado(22) = "" Then rsArquivo("TipoServico") = 999 Else rsArquivo("TipoServico") = ArrayGerado(22) End If 'If ArrayGerado(22) <> vbNullString Then rsArquivo("TipoServico") = ArrayGerado(22) If ArrayGerado(23) <> vbNullString Then rsArquivo("TipoTransporte") = ArrayGerado(23) If ArrayGerado(24) = "" Then 'rsArquivo("CodEstabV") = "999" rsArquivo("CodEstabV") = ArrayGerado(2) Else rsArquivo("CodEstabV") = ArrayGerado(24) End If 'rsArquivo("CodEstabV") = ArrayGerado(24) 'BuscaCodEstabV(ArrayGerado(24)) If ArrayGerado(25) = "" Then rsArquivo("Viagem") = 999 Else rsArquivo("Viagem") = ArrayGerado(25) End If rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblSada()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear 'MsgBox "Erro ao importar arquivo.", vbCritical + vbOKOnly End Sub Private Sub GravaTblVendaDiretaSada(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew rsArquivo("CodEstab") = "16" rsArquivo("CodCidade") = BuscaCodCidade(Replace(ArrayGerado(1), "'", "`"), Replace(ArrayGerado(2), "'", "`")) rsArquivo("Veiculos") = IIf(ArrayGerado(3) <> vbNullString, ArrayGerado(3), 0) rsArquivo("Mes") = Mid(ArrayGerado(0), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(0), 4, 4) If ArrayGerado(4) <> vbNullString Then rsArquivo("VrMercadoria") = CDbl(Replace(ArrayGerado(4), ".", ",")) If ArrayGerado(5) <> vbNullString Then rsArquivo("FreteTotal") = CDbl(Replace(ArrayGerado(5), ".", ",")) If ArrayGerado(6) <> vbNullString Then rsArquivo("VeiculoFunc") = CDbl(Replace(ArrayGerado(6), ".", ",")) If ArrayGerado(7) <> vbNullString Then rsArquivo("VrMercadoriaFunc") = CDbl(Replace(ArrayGerado(7), ".", ",")) If ArrayGerado(8) <> vbNullString Then rsArquivo("FreteFunc") = CDbl(Replace(ArrayGerado(8), ".", ",")) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblCida()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub GravaTblVendaDiretaLocaliza(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew rsArquivo("CodEstab") = "16" rsArquivo("CodCidade") = BuscaCodCidade(Replace(ArrayGerado(1), "'", "`"), Replace(ArrayGerado(2), "'", "`")) rsArquivo("Veiculos") = ArrayGerado(3) rsArquivo("Mes") = Mid(ArrayGerado(0), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(0), 4, 4) If ArrayGerado(4) <> vbNullString Then rsArquivo("VrMercadoria") = CDbl(Replace(ArrayGerado(4), ".", ",")) If ArrayGerado(5) <> vbNullString Then rsArquivo("FreteTotal") = CDbl(Replace(ArrayGerado(5), ".", ",")) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblCida()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub GravaTblFiat(ByRef sLinha As String, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro ''rsArquivo.AddNew '''Mes 01/2003 ''rsArquivo("CodEstab") = BuscaCodEstab(Trim(Mid(sLinha, 4, 1)), True) ''rsArquivo("CodEstado") = BuscaCodEstado(Trim(Mid(sLinha, 5, 2))) ''rsArquivo("CodCidade") = BuscaCodCidade(Trim(Mid(sLinha, 7, 30))) ''rsArquivo("NumCliente") = BuscaCodClienteFiat(Trim(Mid(sLinha, 37, 6)), Replace(Trim(Mid(sLinha, 43, 15)), "'", "`")) ''rsArquivo("NF") = Trim(Mid(sLinha, 58, 7)) ''rsArquivo("DtExped") = (Mid(sLinha, 65, 2) & "/" & Mid(sLinha, 67, 2) & "/" & Mid(sLinha, 69, 4)) ''rsArquivo("Frota") = IIf(IsNumeric(Mid(sLinha, 75, 4)), Mid(sLinha, 75, 4), Null) ''rsArquivo("Chassi") = Trim(Mid(sLinha, 79, 13)) ''rsArquivo("Frete") = Trim(CDbl(Replace(Mid(sLinha, 92, 7), ".", ","))) ''rsArquivo("Km") = IIf(Mid(sLinha, 99, 4) <> "", Trim(Mid(sLinha, 99, 4)), Null) 'Mes 02/2003 - 5 Caracteres a menos no nome do cliente 'rsArquivo("CodEstab") = BuscaCodEstab(Trim(Mid(sLinha, 4, 1)), True) 'rsArquivo("CodEstado") = BuscaCodEstado(Trim(Mid(sLinha, 5, 2))) 'rsArquivo("CodCidade") = BuscaCodCidade(Trim(Mid(sLinha, 7, 25))) 'rsArquivo("NumCliente") = BuscaCodClienteFiat(Trim(Mid(sLinha, 32, 6)), Replace(Trim(Mid(sLinha, 38, 15)), "'", "`")) 'rsArquivo("NF") = Trim(Mid(sLinha, 53, 7)) 'rsArquivo("DtExped") = (Mid(sLinha, 60, 2) & "/" & Mid(sLinha, 62, 2) & "/" & Mid(sLinha, 64, 4)) 'rsArquivo("Frota") = IIf(IsNumeric(Mid(sLinha, 70, 4)), Mid(sLinha, 70, 4), Null) 'rsArquivo("Chassi") = Trim(Mid(sLinha, 74, 13)) 'rsArquivo("Frete") = Trim(CDbl(Replace(Mid(sLinha, 87, 7), ".", ","))) 'rsArquivo("Km") = IIf(Mid(sLinha, 99, 4) <> "", Trim(Mid(sLinha, 99, 4)), Null) '''' rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblFiat()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Sub Private Sub GravaTblConc(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) 'rsArquivo("MesAno") = Arraygerado(2) rsArquivo("Mes") = Mid(ArrayGerado(2), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(2), 4, 4) rsArquivo("Cliente") = Replace(ArrayGerado(3), "'", "") rsArquivo("CodCidade") = BuscaCodCidade(Replace(ArrayGerado(4), "'", ""), Replace(ArrayGerado(5), "'", "")) rsArquivo("Km") = IIf(ArrayGerado(6) <> "", ArrayGerado(6), 0) rsArquivo("VeicCliOU") = IIf(ArrayGerado(7) <> "", ArrayGerado(7), 0) rsArquivo("VeicCliEX") = IIf(ArrayGerado(8) <> "", ArrayGerado(8), 0) rsArquivo("VeicCliVD") = IIf(ArrayGerado(9) <> "", ArrayGerado(9), 0) rsArquivo("VeicCliLO") = IIf(ArrayGerado(10) <> "", ArrayGerado(10), 0) rsArquivo("VeicCliLN") = IIf(ArrayGerado(11) <> "", ArrayGerado(11), 0) rsArquivo("VeicCliPU") = IIf(ArrayGerado(12) <> "", ArrayGerado(12), 0) rsArquivo("VeicCliFU") = IIf(ArrayGerado(13) <> "", ArrayGerado(13), 0) rsArquivo("VeicCliRF") = IIf(ArrayGerado(14) <> "", ArrayGerado(14), 0) rsArquivo("VeicCliPA") = IIf(ArrayGerado(15) <> "", ArrayGerado(15), 0) rsArquivo("VeicCliPG") = IIf(ArrayGerado(16) <> "", ArrayGerado(16), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblConc()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub GravaTblFtfa(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) 'rsArquivo("MesAno") = Arraygerado(2) rsArquivo("Mes") = Mid(ArrayGerado(2), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(2), 4, 4) rsArquivo("QtdVeiculos") = IIf(ArrayGerado(3) <> "", ArrayGerado(3), 0) rsArquivo("FretePuro") = IIf(ArrayGerado(4) <> "", Replace(ArrayGerado(4), ".", ","), 0) rsArquivo("ICMS") = IIf(ArrayGerado(5) <> "", Replace(ArrayGerado(5), ".", ","), 0) rsArquivo("Seguro") = IIf(ArrayGerado(6) <> "", Replace(ArrayGerado(6), ".", ","), 0) rsArquivo("Pedagio") = IIf(ArrayGerado(7) <> "", Replace(ArrayGerado(7), ".", ","), 0) rsArquivo("ISS") = IIf(ArrayGerado(8) <> "", Replace(ArrayGerado(8), ".", ","), 0) rsArquivo("KmCobrado") = IIf(ArrayGerado(9) <> "", ArrayGerado(9), 0) rsArquivo("KmMaior") = IIf(ArrayGerado(10) <> "", ArrayGerado(10), 0) rsArquivo("ValorMercado") = IIf(ArrayGerado(11) <> "", Replace(ArrayGerado(11), ".", ","), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblFtfa()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub ContMensagemStatus(ByRef Linhas As Long) ', ByRef ArrayGerado As Variant) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro lblMsg1 = "Importando registro " & Linhas - 1 & " de " & linhasTxt - 1 & ", aguarde a conclusão..." '& ArrayGerado(0) ProgressBar1.Value = ProgressBar1.Value + 1 Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ContMensagemStatus()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Sub Private Sub ImportaArquivoSada(ByVal rsArquivo As ADODB.Recordset) 'On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim sLinha As String Dim ArrayGerado As Variant Dim Linhas As Long Linhas = 1 Open txtArquivo For Input As #1 If Not EOF(1) Then Line Input #1, sLinha 'Passa primeira linha e desconsidera cabecalho Do While Not EOF(1) DoEvents If bParar = True Then Exit Sub 'força a saída da rotina quando pressionado "Cancelar" Line Input #1, sLinha ContMensagemStatus Linhas ArrayGerado = Split(sLinha, ";", -1) GravaTblSada ArrayGerado, rsArquivo Linhas = Linhas + 1 Loop Close #1 Exit Sub MsgBox "Arquivo Importado", vbInformation + vbOKOnly Error_Handler: 'Rotina de tratamento de erro 'Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ImportaArquivoSada()"), Err.Description, Err.HelpFile, Err.HelpContext) 'Err.Clear Resume Next MsgBox "Importação efetuada com sucesso.", vbOKOnly + vbInformation, "SCEV" End Sub Private Function BuscaCodModelo(ByVal Modelo As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsModelo As ADODB.Recordset If Modelo = "" Or Modelo = "." Then Modelo = "Não informado" Set rsModelo = New ADODB.Recordset rsModelo.Open "SELECT CodModelo From TblModelo WHERE Modelo = '" & Modelo & "'", db, adOpenStatic, adLockOptimistic If rsModelo.EOF Then db.Execute "INSERT INTO TblModelo (Modelo) VALUES ('" & Modelo & "')" Set rsModelo = New ADODB.Recordset rsModelo.Open "SELECT CodModelo From TblModelo WHERE Modelo = '" & Modelo & "'", db, adOpenStatic, adLockOptimistic End If BuscaCodModelo = rsModelo!CodModelo rsModelo.Close Set rsModelo = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodModelo()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function BuscaCodDescricao(ByVal Descricao As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsDescricao As ADODB.Recordset If Descricao = "" Or Descricao = "." Then Descricao = "Não informada" Set rsDescricao = New ADODB.Recordset rsDescricao.Open "SELECT CodDescricao From TblDescricao WHERE Descricao = '" & Descricao & "'", db, adOpenStatic, adLockOptimistic If rsDescricao.EOF Then db.Execute "INSERT INTO TblDescricao (Descricao) VALUES ('" & Descricao & "')" Set rsDescricao = New ADODB.Recordset rsDescricao.Open "SELECT CodDescricao From TblDescricao WHERE Descricao = '" & Descricao & "'", db, adOpenStatic, adLockOptimistic End If BuscaCodDescricao = rsDescricao!CodDescricao rsDescricao.Close Set rsDescricao = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodDescricao()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Sub GravaTblVico(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) 'rsArquivo("MesAno") = Arraygerado(2) rsArquivo("Mes") = Mid(ArrayGerado(2), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(2), 4, 4) VerificaCliente ArrayGerado(3) rsArquivo("CodCliente") = ArrayGerado(3) rsArquivo("TipoEntrega") = ArrayGerado(4) rsArquivo("QtdVeiculos") = IIf(ArrayGerado(5) <> "", ArrayGerado(6), 0) rsArquivo("QtdEntregas") = IIf(ArrayGerado(6) <> "", ArrayGerado(6), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblVico()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub GravaTblViuf(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) 'rsArquivo("MesAno") = Arraygerado(2) rsArquivo("Mes") = Mid(ArrayGerado(2), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(2), 4, 4) rsArquivo("CodEstado") = BuscaCodEstado(ArrayGerado(3)) rsArquivo("TipoEntrega") = ArrayGerado(4) rsArquivo("QtdVeiculos") = IIf(ArrayGerado(5) <> "", ArrayGerado(5), 0) rsArquivo("QtdEntregas") = IIf(ArrayGerado(6) <> "", ArrayGerado(6), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblViuf()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub GravaTblCida(ByRef ArrayGerado As Variant, _ ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro rsArquivo.AddNew If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(1) = "NC" Then ArrayGerado(1) = "LN" rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(1)) rsArquivo("Mes") = Mid(ArrayGerado(2), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(2), 4, 4) 'rsArquivo("MesAno") = Arraygerado(2) rsArquivo("CodCidade") = BuscaCodCidade(Replace(ArrayGerado(3), "'", "`"), Replace(ArrayGerado(4), "'", "`")) rsArquivo("Km") = IIf(ArrayGerado(5) <> "", ArrayGerado(5), 0) rsArquivo("VeicCidOU") = IIf(ArrayGerado(6) <> "", ArrayGerado(6), 0) rsArquivo("VeicCidEX") = IIf(ArrayGerado(7) <> "", ArrayGerado(7), 0) rsArquivo("VeicCidVD") = IIf(ArrayGerado(8) <> "", ArrayGerado(8), 0) rsArquivo("VeicCidLO") = IIf(ArrayGerado(9) <> "", ArrayGerado(9), 0) rsArquivo("VeicCidLN") = IIf(ArrayGerado(10) <> "", ArrayGerado(10), 0) rsArquivo("VeicCidPU") = IIf(ArrayGerado(11) <> "", ArrayGerado(11), 0) rsArquivo("VeicCidFU") = IIf(ArrayGerado(12) <> "", ArrayGerado(12), 0) rsArquivo("VeicCidRF") = IIf(ArrayGerado(13) <> "", ArrayGerado(13), 0) rsArquivo("VeicCidPA") = IIf(ArrayGerado(14) <> "", ArrayGerado(14), 0) rsArquivo("VeicCidPG") = IIf(ArrayGerado(15) <> "", ArrayGerado(15), 0) rsArquivo.Update Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblCida()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Sub ImportaOutrosArquivos(ByRef rsArquivo As ADODB.Recordset, ByVal Tabela As String) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim sLinha As String Dim ArrayGerado As Variant Dim Linhas As Long Linhas = 1 Open txtArquivo For Input As #1 If Not EOF(1) Then Line Input #1, sLinha 'Desconsidera primeira linha Do While Not EOF(1) DoEvents If bParar Then Exit Sub Linhas = Linhas + 1 Line Input #1, sLinha ContMensagemStatus Linhas ArrayGerado = Split(sLinha, ";", -1) Select Case Tabela Case "TBLCIDA": GravaTblCida ArrayGerado, rsArquivo Case "TBLCONC": GravaTblConc ArrayGerado, rsArquivo Case "TBLVICI": GravaTblVici ArrayGerado, rsArquivo Case "TBLVIEN": GravaTblVien ArrayGerado, rsArquivo Case "TBLVICO": GravaTblVico ArrayGerado, rsArquivo Case "TBLVIUF": GravaTblViuf ArrayGerado, rsArquivo Case "TBLFTFA": GravaTblFtfa ArrayGerado, rsArquivo Case "TBLKMFROTA": GravaTblKmFr ArrayGerado, rsArquivo End Select Loop Close #1 Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ImportaArquivoTxtOutrosArq()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Sub Private Sub GravaTblKmFr(ByRef ArrayGerado As Variant, ByRef rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsaux As ADODB.Recordset Dim sSQL As String If ArrayGerado(0) = 1 Then ArrayGerado(0) = 16 If ArrayGerado(2) = "NC" Then ArrayGerado(2) = "LN" Select Case ArrayGerado(1) Case "1000": ArrayGerado(1) = "NOR" Case "21000": ArrayGerado(1) = "TEG" End Select If ArrayGerado(1) = "TEG" Or ArrayGerado(1) = "NOR" Then sSQL = "SELECT TblKmFrota.CodEstab, TblKmFrota.CodTipoFrota, TblKmFrota.CodTipo, TblKmFrota.Mes, TblKmFrota.Ano, TblKmFrota.KMCobrado, TblKmFrota.KmMaior, TblKmFrota.QteVeiculos" sSQL = sSQL & " FROM TblTipoFrota INNER JOIN (TblTipoServico INNER JOIN TblKmFrota ON TblTipoServico.CodTipo = TblKmFrota.CodTipo) ON TblTipoFrota.CodTipoFrota = TblKmFrota.CodTipoFrota" sSQL = sSQL & " WHERE TblKmFrota.CodEstab=" & ArrayGerado(0) & " AND TblTipoServico.SiglaTipo= '" & ArrayGerado(2) & "' AND TblTipoFrota.TipoFrota= '" & ArrayGerado(1) & "' AND TblKmFrota.Mes=" & Mid(ArrayGerado(3), 1, 2) & " AND TblKmFrota.Ano=" & Mid(ArrayGerado(3), 4, 4) & ";" Set rsaux = New ADODB.Recordset rsaux.Open sSQL, db, adOpenStatic, adLockOptimistic If Not rsaux.EOF Then rsaux("CodEstab") = ArrayGerado(0) rsaux("CodTipoFrota") = BuscaCodTipoFrota(ArrayGerado(1)) rsaux("CodTipo") = BuscaCodTipo(ArrayGerado(2)) rsaux("Mes") = Mid(ArrayGerado(3), 1, 2) rsaux("Ano") = Mid(ArrayGerado(3), 4, 4) rsaux("KmCobrado") = ArrayGerado(4) + rsaux("KmCobrado") rsaux("KmMaior") = ArrayGerado(6) + rsaux("KmMaior") rsaux("QteVeiculos") = ArrayGerado(5) + rsaux("QteVeiculos") Else rsaux.AddNew rsaux("CodEstab") = ArrayGerado(0) rsaux("CodTipoFrota") = BuscaCodTipoFrota(ArrayGerado(1)) rsaux("CodTipo") = BuscaCodTipo(ArrayGerado(2)) rsaux("Mes") = Mid(ArrayGerado(3), 1, 2) rsaux("Ano") = Mid(ArrayGerado(3), 4, 4) rsaux("KmCobrado") = ArrayGerado(4) rsaux("KmMaior") = ArrayGerado(6) rsaux("QteVeiculos") = ArrayGerado(5) End If rsaux.Update rsaux.Close Set rsaux = Nothing Else rsArquivo.AddNew rsArquivo("CodEstab") = ArrayGerado(0) rsArquivo("CodTipoFrota") = BuscaCodTipoFrota(ArrayGerado(1)) rsArquivo("CodTipo") = BuscaCodTipo(ArrayGerado(2)) rsArquivo("Mes") = Mid(ArrayGerado(3), 1, 2) rsArquivo("Ano") = Mid(ArrayGerado(3), 4, 4) rsArquivo("KmCobrado") = ArrayGerado(4) rsArquivo("KmMaior") = ArrayGerado(6) rsArquivo("QteVeiculos") = ArrayGerado(5) End If Exit Sub Error_Handler: 'Rotina de tratamento de erro If Err.Number = 9 Then Resume Next Else Call Err.Raise(Err.Number, ErrSource("FrmImportar", "GravaTblKmFr()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End If End Sub Private Function BuscaCodTipoFrota(ByVal Frota As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsFrota As ADODB.Recordset Set rsFrota = New ADODB.Recordset rsFrota.Open "SELECT CodTipoFrota From TblTipoFrota WHERE TipoFrota= '" & Frota & "'", db, adOpenStatic, adLockOptimistic If rsFrota.EOF Then db.Execute "INSERT INTO TblTipoFrota (TipoFrota) VALUES ( '" & Frota & "')" Set rsFrota = New ADODB.Recordset rsFrota.Open "SELECT CodTipoFrota From TblTipoFrota WHERE TipoFrota= '" & Frota & "'", db, adOpenStatic, adLockOptimistic End If BuscaCodTipoFrota = rsFrota!CodTipoFrota rsFrota.Close Set rsFrota = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodTipoFrota()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Sub VerificaCliente(ByVal Cliente As String) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsCliente As ADODB.Recordset Set rsCliente = New ADODB.Recordset rsCliente.Open "SELECT * FROM TblClienteSada WHERE CodCLiente = " & "'" & Cliente & "'", db, adOpenStatic, adLockOptimistic If rsCliente.EOF Then rsCliente.AddNew rsCliente!CodCliente = Cliente rsCliente.Update End If rsCliente.Close Set rsCliente = Nothing Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "VerificaCliente()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Sub Private Sub VerificaFrota(ByVal Frota As Integer) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsFrota As ADODB.Recordset Set rsFrota = New ADODB.Recordset rsFrota.Open "SELECT * FROM TblFrota WHERE NumFrota = " & "" & Frota & "", db, adOpenStatic, adLockOptimistic If rsFrota.EOF Then rsFrota.AddNew If Frota = 1000 Then rsFrota!CodTipoFrota = 6 ElseIf Frota = 21000 Then rsFrota!CodTipoFrota = 10 ElseIf Frota = 2921 Or Frota = 2926 Or Frota = 2927 Then rsFrota!CodTipoFrota = 8 ElseIf Frota = 28000 Then rsFrota!CodTipoFrota = 9 ElseIf Frota > 1000 And Frota < 1200 Then rsFrota!CodTipoFrota = 8 ElseIf Frota > 9999 And Frota < 30001 Then rsFrota!CodTipoFrota = 10 ElseIf Frota > 1199 And Frota < 2900 Then rsFrota!CodTipoFrota = 6 ElseIf Frota > 200 And Frota < 901 Then rsFrota!CodTipoFrota = 9 ElseIf Frota > 8999 And Frota < 10000 Then rsFrota!CodTipoFrota = 5 ElseIf Frota > 3000 And Frota < 4000 Then rsFrota!CodTipoFrota = 8 ElseIf Frota > 99 And Frota < 200 Then rsFrota!CodTipoFrota = 4 ElseIf Frota > 2899 And Frota < 3001 Then rsFrota!CodTipoFrota = 2 Else rsFrota!CodTipoFrota = 7 End If rsFrota!NumFrota = Frota rsFrota.Update End If rsFrota.Close Set rsFrota = Nothing Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "VerificaFrota()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear Resume End Sub Private Function BuscaCodCliente(ByVal Cliente As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsCliente As ADODB.Recordset Set rsCliente = New ADODB.Recordset rsCliente.Open "SELECT CodCliente FROM TblClienteSada WHERE Cliente = '" & Cliente & "'", db, adOpenStatic, adLockOptimistic If rsCliente.EOF Then db.Execute "INSERT INTO TblClienteSada (Cliente) VALUES ( '" & Cliente & "')" Set rsCliente = New ADODB.Recordset rsCliente.Open "SELECT CodCliente FROM TblClienteSada WHERE Cliente = '" & Cliente & "'", db, adOpenStatic, adLockOptimistic End If BuscaCodCliente = rsCliente!CodCliente rsCliente.Close Set rsCliente = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodCliente()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function BuscaCodTipo(ByVal Tipo As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsTipo As ADODB.Recordset Set rsTipo = New ADODB.Recordset rsTipo.Open "SELECT CodTipo FROM TblTipoServico WHERE DescTipo = '" & Tipo & "'", db, adOpenStatic, adLockOptimistic If rsTipo.EOF Then db.Execute "INSERT INTO TblTipoServico (SiglaTipo) VALUES ( '" & Tipo & "')" Set rsTipo = New ADODB.Recordset rsTipo.Open "SELECT CodTipo FROM TblTipoServico WHERE DescTipo = '" & Tipo & "'", db, adOpenStatic, adLockOptimistic End If BuscaCodTipo = rsTipo!CodTipo rsTipo.Close Set rsTipo = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodTipo()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function BuscaCodCidade(ByVal Cidade As String, ByVal Estado As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim CodEstado As Integer Dim rsCidade As ADODB.Recordset If Cidade = vbNullString Or Cidade = "." Then Cidade = "Não informada" CodEstado = BuscaCodEstado(Estado) Set rsCidade = New ADODB.Recordset rsCidade.Open "SELECT CodCidade From TblCidade WHERE CodEstado = " & CodEstado & " AND DescCidade = '" & Cidade & "'", db, adOpenStatic, adLockOptimistic If rsCidade.EOF Then db.Execute "INSERT INTO TblCidade (CodEstado, DescCidade) VALUES (" & CodEstado & ",'" & Cidade & "')" Set rsCidade = New ADODB.Recordset rsCidade.Open "SELECT CodCidade From TblCidade WHERE CodEstado = " & CodEstado & " AND DescCidade = '" & Cidade & "'", db, adOpenStatic, adLockOptimistic End If BuscaCodCidade = rsCidade!CodCidade rsCidade.Close Set rsCidade = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodCidade()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function BuscaCodEstado(ByVal Estado As String) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsEstado As ADODB.Recordset If Estado = vbNullString Or Estado = "." Then Estado = "Não informado" Set rsEstado = New ADODB.Recordset If Not (optTipo(10) Or optTipo(11)) Then rsEstado.Open "SELECT CodEstado From TblEstado WHERE SiglaEstado = '" & Estado & "'", db, adOpenStatic, adLockOptimistic If rsEstado.EOF Then db.Execute "INSERT INTO TblEstado (SiglaEstado) VALUES ('" & Estado & "')" Set rsEstado = New ADODB.Recordset rsEstado.Open "SELECT CodEstado From TblEstado WHERE SiglaEstado = '" & Estado & "'", db, adOpenStatic, adLockOptimistic End If Else rsEstado.Open "SELECT CodEstado From TblEstado WHERE SiglaEstado = '" & Estado & "'", db, adOpenStatic, adLockOptimistic If rsEstado.EOF Then db.Execute "INSERT INTO TblEstado (SiglaEstado) VALUES ('" & Estado & "')" Set rsEstado = New ADODB.Recordset rsEstado.Open "SELECT CodEstado From TblEstado WHERE SiglaEstado = '" & Estado & "'", db, adOpenStatic, adLockOptimistic End If End If BuscaCodEstado = rsEstado!CodEstado rsEstado.Close Set rsEstado = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodEstado()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function BuscaCodEstab(ByVal Estab As String, Optional ByVal SiglaFiat As Boolean) As Integer On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsEstab As ADODB.Recordset Set rsEstab = New ADODB.Recordset If Not SiglaFiat Then rsEstab.Open ("SELECT CodEstab FROM TblEstabelecimento WHERE CodEstab = '" & Estab & "'"), db, adOpenStatic, adLockOptimistic If rsEstab.EOF Then Set rsEstab = New ADODB.Recordset rsEstab.Open ("SELECT Max(CodEstab) AS MaiorCodEstab FROM TblEstabelecimento;"), db, adOpenStatic, adLockOptimistic db.Execute ("INSERT INTO TblEstabelecimento (CodEstab, SiglaEstab ) VALUES (" & rsEstab!MaiorCodEstab + 1 & ", '" & Estab & "')") Set rsEstab = New ADODB.Recordset rsEstab.Open ("SELECT CodEstab FROM TblEstabelecimento WHERE SiglaEstab = '" & Estab & "'"), db, adOpenStatic, adLockOptimistic End If Else rsEstab.Open ("SELECT CodEstab FROM TblEstabelecimento WHERE SiglaFiat = '" & Estab & "'"), db, adOpenStatic, adLockOptimistic If rsEstab.EOF Then Set rsEstab = New ADODB.Recordset rsEstab.Open ("SELECT Max(CodEstab) AS MaiorCodEstab FROM TblEstabelecimento"), db, adOpenStatic, adLockOptimistic db.Execute ("INSERT INTO TblEstabelecimento ( CodEstab, SiglaFiat ) VALUES ( " & rsEstab!MaiorCodEstab + 1 & ", '" & Estab & "')") Set rsEstab = New ADODB.Recordset rsEstab.Open ("SELECT CodEstab FROM TblEstabelecimento WHERE SiglaFiat = '" & Estab & "'"), db, adOpenStatic, adLockOptimistic End If End If BuscaCodEstab = rsEstab!CodEstab rsEstab.Close Set rsEstab = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "BuscaCodEstab()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Sub ValidaArqFiat() ''Dim rsControle As ADODB.Recordset ' 'If UCase(Dir(txtArquivo)) <> UCase("Fiat" & Format(DTArquivo, "mm") & Format(DTArquivo, "yy") & ".txt") Then ' MsgBox "O nome do arquivo não confere com os dados informados." & vbLf & "Para o mês " & Format(DTArquivo, "mm") & "/" & Year(DTArquivo) & " selecione o arquivo" & " Fiat" & Format(DTArquivo, "mm") & Format(DTArquivo, "yy") & ".txt !", vbQuestion, "Importar arquivo mensal da Fiat" ' Exit Sub 'End If ' ''Set rsControle = New ADODB.Recordset ''rsControle.Open "SELECT Mes, Ano FROM TblContImportacao WHERE TblContImportacao.Mes = " & Month(DTArquivo) & " AND TblContImportacao.Ano = " & Year(DTArquivo) & " AND Origem = 2;", db, adOpenStatic, adLockOptimistic ''If rsControle.RecordCount > 0 Then '' MsgBox "Os registros da Fiat - Mês " & Format(DTArquivo, "mm") & "/" & Format(DTArquivo, "yyyy") & " já foram importados." & vbLf & "e não será possível importá-los novamente !", vbInformation, "Importação cancelada" '' Exit Sub ''End If ' 'Me.MousePointer = 13 'LeArquivoTexto 'ImportarArquivoTxtFiat End Sub Private Function ValidaBanco() As Boolean 'Verifica se arquivo selecionado já foi importado On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsArquivo As ADODB.Recordset Set rsArquivo = New ADODB.Recordset rsArquivo.Open "SELECT * FROM TblContImportacao WHERE NomeArquivo = '" & txtArquivo & "'", db, adOpenStatic, adLockOptimistic If Not rsArquivo.EOF Then MsgBox "O arquivo " & txtArquivo & " já foi importado em " & rsArquivo!DataImportacao & "." & vbLf & "Não será possível importá-lo novamente!", vbInformation + vbOKOnly ValidaBanco = False Else ValidaBanco = True End If rsArquivo.Close Set rsArquivo = Nothing Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "VerificaBanco()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear Resume End Function Private Function ValidaSelecao() As Boolean On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro If IsNull(txtArquivo) Then 'Verifica se foi informado arquivo MsgBox "Selecione o arquivo que deve ser importado!", vbInformation + vbOKOnly ValidaSelecao = False Exit Function End If If Not (optTipo(0) Or optTipo(1) Or optTipo(2) Or optTipo(3) Or optTipo(4) Or optTipo(5) Or optTipo(6) Or optTipo(7) Or optTipo(8) Or optTipo(9) Or optTipo(10) Or optTipo(11)) Then MsgBox "Selecione a origem do arquivo que será importado!", vbInformation, "Importar arquivo mensal" ValidaSelecao = False Exit Function End If ValidaSelecao = True Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ValidaSelecao()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Sub CmdImportar_Click() 'On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro bParar = False If Not ValidaSelecao Then Exit Sub If Not ValidaDtArquivo Then Exit Sub If Not ValidaNomeArquivo Then Exit Sub If Not ValidaBanco Then Exit Sub ContProgressoBotoes True If Not LeArquivoTexto Then Exit Sub ContIniciaBarraProgressso If Not SelecionaArquivos Then Exit Sub If Not FinalizaImportacao Then Exit Sub ContProgressoBotoes False Exit Sub Error_Handler: 'Rotina de tratamento de erro 'Call ExibirMsgErro(mcstrNomeModulo, "cmdImportar_Click()") 'Err.Clear bParar = True FinalizaImportacao ContProgressoBotoes False End Sub Private Function SelecionaArquivos() As Boolean 'On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim rsArquivo As ADODB.Recordset Set rsArquivo = New ADODB.Recordset If optTipo(0) Then rsArquivo.Open "SELECT * FROM TblCida", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLCIDA" ElseIf optTipo(1) Then rsArquivo.Open "SELECT * FROM TblConc", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLCONC" ElseIf optTipo(2) Then rsArquivo.Open "SELECT * FROM TblVici", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLVICI" ElseIf optTipo(3) Then rsArquivo.Open "SELECT * FROM TblVien", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLVIEN" ElseIf optTipo(4) Then rsArquivo.Open "SELECT * FROM TblVico", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLVICO" ElseIf optTipo(5) Then rsArquivo.Open "SELECT * FROM TblViuf", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLVIUF" ElseIf optTipo(6) Then rsArquivo.Open "SELECT * FROM TblFtfa", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLFTFA" ElseIf optTipo(7) Then 'rsArquivo.Open "SELECT * FROM TblSada", db, adOpenStatic, adLockOptimistic rsArquivo.Open "SELECT * FROM TblSada", db, adOpenStatic, adLockOptimistic ImportaArquivoSada rsArquivo ElseIf optTipo(8) Then rsArquivo.Open "SELECT * FROM TblFiat", db, adOpenStatic, adLockOptimistic ImportaArquivoFiat rsArquivo ElseIf optTipo(10) Then rsArquivo.Open "SELECT * FROM TblVendaDiretaSada", db, adOpenStatic, adLockOptimistic ImportaArquivoVendaDiretaSada rsArquivo ElseIf optTipo(11) Then rsArquivo.Open "SELECT * FROM TblVendaDiretaLocaliza", db, adOpenStatic, adLockOptimistic ImportaArquivoVendaDiretaLocaliza rsArquivo Else rsArquivo.Open "SELECT * FROM TblKmFrota", db, adOpenStatic, adLockOptimistic ImportaOutrosArquivos rsArquivo, "TBLKMFROTA" End If 'rsArquivo.Close Set rsArquivo = Nothing SelecionaArquivos = True Exit Function Error_Handler: 'Rotina de tratamento de erro 'Call Err.Raise(Err.Number, ErrSource("FrmImportar", "SelecionaArquivos()"), Err.Description, Err.HelpFile, Err.HelpContext) 'Err.Clear Resume End Function Private Function FinalizaImportacao() As Boolean On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro If Not bParar Then MsgBox "Processo concluído com sucesso. " & vbLf & "Foram importados " & linhasTxt - 1 & " registros !", vbInformation, "Importação de arquivo mensal" db.Execute "INSERT INTO [TblContImportacao] (Ano, Mes, NomeArquivo, DataImportacao, Registros) VALUES (" & (Year(DTArquivo)) & ", " & (Month(DTArquivo)) & ", '" & Dir(txtArquivo) & "', #" & Month(Date) & "/" & Day(Date) & "/" & Year(Date) & "#, " & linhasTxt - 1 & ");" Else If optTipo(0) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblCida WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(1) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblConc WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(2) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblVici WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(3) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblVien WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(4) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblVico WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(5) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblViuf WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(6) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblFtfa WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" ElseIf optTipo(7) Then db.Execute "DELETE * From TblSada WHERE (((Month([DtExped]))= " & Month(DTArquivo) & " ) AND ((Year([DtExped]))= " & Year(DTArquivo) & " ));" ElseIf optTipo(9) Then db.Execute "DELETE Mes AS Mes, Ano AS Ano From TblKmFrota WHERE Mes= " & Month(DTArquivo) & " AND Ano= " & Year(DTArquivo) & ";" Else 'excluir registros importados no mês - Fiat End If MsgBox "Procedimento cancelado!", vbInformation + vbOKOnly End If FinalizaImportacao = True Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "FinalizaImportacao()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Sub ContProgressoBotoes(Bln As Boolean) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro CmdImportar.Enabled = Not Bln cmdFechar.Enabled = Not Bln cmdCancelar.Enabled = Bln lblMsg1.Visible = Bln lblMsg1.ForeColor = &HFF& ProgressBar1.Visible = Bln Me.MousePointer = IIf(Bln = True, 13, 0) Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ContProgressoBotoes()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Sub Private Function ValidaDtArquivo() As Boolean On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro 'Verifica se nome do arquivo selecionado coincide com mes e ano informados If Not (Not optTipo(7) Or Not optTipo(8)) Then If Mid(DTArquivo, 4, 2) & Mid(DTArquivo, 7, 2) <> Mid(txtArquivo, 5, 4) Then MsgBox "A data selecionada é diferente da data do arquivo!", vbInformation + vbOKOnly ValidaDtArquivo = False Exit Function End If ElseIf optTipo(7) Then 'verifica data do arquivo sada If Mid(DTArquivo, 4, 2) & Mid(DTArquivo, 9, 2) <> Mid(txtArquivo, 4, 4) Then MsgBox "A data selecionada é diferente da data do arquivo!", vbInformation + vbOKOnly ValidaDtArquivo = False Exit Function End If ElseIf (optTipo(10) Or optTipo(11)) Then 'Arquivo Venda Direta Sada If Mid(DTArquivo, 4, 2) <> Mid(txtArquivo, 7, 2) Then MsgBox "A data selecionada é diferente da data do arquivo!", vbInformation + vbOKOnly ValidaDtArquivo = False Exit Function End If Else 'verifica data do arquivo fiat End If ValidaDtArquivo = True Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ValidaDtArquivo()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Function ValidaNomeArquivo() As Boolean On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro 'Verifica se arquivo informado é o mesmo do nome de arquivo selecionado If optTipo(0) Then If UCase(Left(txtArquivo, 4)) <> "CIDA" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(1) Then If UCase(Left(txtArquivo, 4)) <> "CONC" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(2) Then If UCase(Left(txtArquivo, 4)) <> "VICI" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(3) Then If UCase(Left(txtArquivo, 4)) <> "VIEN" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(4) Then If UCase(Left(txtArquivo, 4)) <> "VICO" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(5) Then If UCase(Left(txtArquivo, 4)) <> "VIUF" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(6) Then If UCase(Left(txtArquivo, 4)) <> "FTFA" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(7) Then If UCase(Left(txtArquivo, 3)) <> "CHA" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(10) Then If UCase(Left(txtArquivo, 6)) <> "FTVDSA" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If ElseIf optTipo(11) Then If UCase(Left(txtArquivo, 6)) <> "FTVDLO" Then MsgBox "O nome do arquivo é diferente do tipo de arquivo selecionado para importação." & vbLf & "Informe o tipo de arquivo correto para iniciar a importação !", vbInformation + vbOKOnly ValidaNomeArquivo = False Exit Function End If Else 'if 'Verificar arquivo da fiat End If ValidaNomeArquivo = True Exit Function Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ValidaNomeArquivo()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Function Private Sub ImportaArquivoFiat(ByVal rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina de tratamento de erro Dim sLinha As String Dim Linhas As Long Linhas = 1 Open txtArquivo For Input As #1 Do While Not EOF(1) DoEvents If bParar = True Then Exit Sub 'força a saída da rotina quando pressionado "Cancelar" Line Input #1, sLinha ContMensagemStatus Linhas GravaTblFiat sLinha, rsArquivo Linhas = Linhas + 1 Loop Close #1 Exit Sub Error_Handler: 'Rotina de tratamento de erro Call Err.Raise(Err.Number, ErrSource("FrmImportar", "ImportaArquivoFiat()"), Err.Description, Err.HelpFile, Err.HelpContext) Err.Clear End Sub Private Sub ImportaArquivoVendaDiretaSada(ByVal rsArquivo As ADODB.Recordset) On Error GoTo Error_Handler 'Ativa a rotina

Prezados, Estou com um novo problema na importação de arquivos texto. Estou recebendo uma mensagem de erro em tempo de execução (run-time error), informando que o tamanho do campo é muito pequeno para aceitar o valor que está se tentando inserir. Abaixo transcrevo a mensagem de erro que estou recebendo: << Run-time error '-2147217833(80040e57)': The field is too small to accept the amount of data you attempted to add. Try inserting or pasting less data. >> O campo que está referenciando este erro tem participa do relacionamento da tabela-pai (origem) e a tabela-filho (onde estão sendo gravados os dados). Tanto na tabela-pai quanto na tabela-filho este campo tem o mesmo tamanho de dados (inteiro longo), porém na tabela-pai possue o tipo de dados de AutoNumeração com a opção de Incremento para o item NovosValores e na tabela-filho (dados gravados) está com o tipo de dados número. Caso queiram dar uma olhada no código-fonte e obter maiores informações, favor me contactarem através do email: jackson_analista@yahoo.com.br. Tenho uma certa urgência em solucionar este problema. Ficarei muito grato se alguém puder me ajudar. Atenciosamente, Jackson Arruda Analista de Sistemas jackson_analista@yahoo.com.br