REGISTROS DE UM BDD PARA TXT E VICE IVERSA

USUARIO.EXCLUIDOS 10/04/2004 02:45:07
#19735 Resposta escolhida

Public Sub ExportaTabela(Tabela As ADODB.Recordset, Arquivo As String, Optional IncluiHeader As Boolean = False)
On Error GoTo ETBErr:
Dim oFS As FileSystemObject
Dim oTS As TextStream
Dim oFL As ADODB.Field
Dim sTexto As String
Dim sLinha As String
Dim sCabeçalho As String
sTexto = Empty
sLinha = Empty
sCabeçalho = Empty
If IncluiHeader = True Then
For Each oFL In Tabela.Fields
If oFL.DefinedSize Len(oFL.Name) Then
sCabeçalho = sCabeçalho & " " & oFL.Name & " "
sLinha = sLinha & String(Len(oFL.Name) + 2, " ")
Else
sCabeçalho = sCabeçalho & " " & oFL.Name & String(oFL.DefinedSize - ((oFL.Name) + 1), " ")
sLinha = sLinha & String(oFL.DefinedSize + 2, " ")
End If
End Sub
End If
Tabela.MoveFirst
While Not Tabela.EOF = True
For Each oFL In Tabela.Fields
If oFL.DefinedSize Len(oFL.Name) Then
sTexto = sTexto & " " & oFL.Value & String(Len((oFL.Name) + 2) - Len(oFL.Value), " ")
Else
sTexto = sTexto & " " & oFL.Value & String((oFL.DefinedSize + 2) - oFL.DefinedSize, " ")
End If
Next
sTexto = sTexto & vbCrLf
Tabela.MoveNext
Wend
Set oFS = New FileSystemObject
If Not oFS.FileExists(Arquivo) = False Then
If MsgBox("Arquivo já existe. Deseja sobrescrevê-lo?", vbYesNo + vbQuestion) = vbYes Then
oFS.DeleteFile Arquivo
Else

End If
Set oTS = oFS.OpenTextFile(Arquivo, ForWriting, True, TristateUseDefault)
If IncluiHeader = True Then
oTS.WriteLine sLinha
oTS.WriteLine sCabeçalho
oTS.WriteLine sLinha
End If
oTS.Write sTexto
oTS.Close
Set oTS = Nothing
End If
ETBErr:
MsgBox Err.Description
Err.Clear
ETBExit:
Set oFS = FileSystemObject
Set oTS = TextStream
Set oFL = ADODB.Field
sTexto = Empty
sLinha = Empty
sCabeçalho = Empty
End Sub