How write into text file at first and last line with excel vba?

  • Thread starter Thread starter geniusideas
  • Start date Start date
G

geniusideas

Hi,

I need help to complete my project, thru excel vba i need to open text
file. Inside this file contain text with CSV which is consist multiple
line. The problem now I need to put something at 1st line and last
line as a header and footer. Please help with the coding. Thanks
 
Sorry, One more thing! After complete I need to change file
extension .txt to .TDAT file and save. Thanks
 
geniusideas said:
Sorry, One more thing! After complete I need to change file
extension .txt to .TDAT file and save. Thanks
Click to expand...

One way (fast & uses a single file):
Sub mangleTextFile1(textFile As String, header As String, footer As String)
Dim contents As String
Open textFile For Binary As 1
contents = Space$(LOF(1))
Get #1, 1, contents
Put #1, 1, header & vbCrLf
Put #1, , contents
If Right$(contents, 2) <> vbCrLf Then Put #1, , vbCrLf
Put #1, , footer
Close
Name textFile As Replace(textFile, ".txt", ".TDAT", _
Compare:=vbTextCompare)
End Sub

Another way (not as fast & uses two files, but more suitable for very large
files):
Sub mangleTextFile2(textFile As String, header As String, footer As String)
Dim contents As String
Open textFile For Input As 1
Open Replace(textFile, ".txt", ".TDAT", Compare:=vbTextCompare) _
For Output As 2
Print #2, header
Do Until EOF(1)
Line Input #1, contents
Print #2, contents
Loop
Print #2, footer
Close
Kill "textfile name here.txt"
End Sub
 
Try...

Option Explicit

Sub Insert_FileHeaderAndFooter()
Dim sTextOut$, sFileIn$, sFileOut$ 'as sring
Const sHeader$ = "My,header,text" '..edit to suit
Const sFooter$ = "My,footer,text" '..edit to suit

'Get the file to open and the new file to SaveAs
sFileIn = Get_FileToOpen: sFileOut = Get_FileToSave
If sFileIn = "" Or sFileOut = "" Then Exit Sub

'Insert header/footer and write to the new file
sTextOut = sHeader & vbCrLf _
& ReadTextFileContents(sFileIn) _
& vbCrLf & sFooter
WriteTextFileContents sTextOut, sFileOut
End Sub


'//Helper functions
'''''''''''''''''''
Function ReadTextFileContents(Filename As String) As String
' Reads large amounts of data from a text file in one single step.
Dim iNum As Integer
On Error GoTo ErrHandler
iNum = FreeFile(): Open Filename For Input As #iNum
ReadTextFileContents = Space$(LOF(iNum))
ReadTextFileContents = Input(LOF(iNum), iNum)

ErrHandler:
Close #iNum: If Err Then Err.Raise Err.Number, , Err.Description
End Function 'ReadTextFileContents()

Sub WriteTextFileContents(ByVal TextOut As String, _
Filename As String, _
Optional AppendMode As Boolean = False)
' Writes/Overwrites or Appends large amounts of data to a Text file
' in one single step.
Dim iNum As Integer
On Error GoTo ErrHandler
iNum = FreeFile()
If AppendMode Then TextOut = vbCrLf & TextOut
Open Filename For Output As #iNum: Print #iNum, TextOut;

ErrHandler:
Close #iNum: If Err Then Err.Raise Err.Number, , Err.Description
End Sub 'WriteTextFileContents()

Function Get_FileToOpen$(Optional FileTypes$)
' Returns the full path and filename of a file to open.
Dim v As Variant
If FileTypes = "" Then FileTypes = "All Files ""*.*"", (*.*)"
v = Application.GetOpenFilename(FileTypes)
If (Not v = False) Then Get_FileToOpen = v Else Get_FileToOpen = ""
End Function

Function Get_FileToSave$(Optional FileOut$)
' Returns the full path and filename of a file to save.
Dim v As Variant
v = Application.GetSaveAsFilename(FileOut)
If (Not v = False) Then Get_FileToSave = v Else Get_FileToSave = ""
End Function

--
Garry

Free usenet access at http://www.eternal-september.org
ClassicVB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Back
Top