I am trying to delete some specific lines of a text using VB.Net. I saw a solution here however it is in VB6. The problem is, I am not really familiar with VB6. Can somebody help me?
This is the code from the link:
Public Function DeleteLine(ByVal fName As String, ByVal LineNumber As Long) _As Boolean
'Purpose: Deletes a Line from a text file
'Parameters: fName = FullPath to File
' LineNumber = LineToDelete
'Returns: True if Successful, false otherwise
'Requires: Reference to Microsoft Scripting Runtime
'Example: DeleteLine("C:\Myfile.txt", 3)
' Deletes third line of Myfile.txt
'______________________________________________________________
Dim oFSO As New FileSystemObject
Dim oFSTR As Scripting.TextStream
Dim ret As Long
Dim lCtr As Long
Dim sTemp As String, sLine As String
Dim bLineFound As Boolean
On Error GoTo ErrorHandler
If oFSO.FileExists(fName) Then
oFSTR = oFSO.OpenTextFile(fName)
lCtr = 1
Do While Not oFSTR.AtEndOfStream
sLine = oFSTR.ReadLine
If lCtr <> LineNumber Then
sTemp = sTemp & sLine & vbCrLf
Else
bLineFound = True
End If
lCtr = lCtr + 1
Loop
oFSTR.Close()
oFSTR = oFSO.CreateTextFile(fName, True)
oFSTR.Write(sTemp)
DeleteLine = bLineFound
End If
ErrorHandler:
On Error Resume Next
oFSTR.Close()
oFSTR = Nothing
oFSO = Nothing
End Function
Dim delLine As Integer = 10
Dim lines As List(Of String) = System.IO.File.ReadAllLines("infile.txt").ToList
lines.RemoveAt(delLine - 1) ' index starts at 0
System.IO.File.WriteAllLines("outfile.txt", lines)
'This can also be the file that you read in
Dim str As String = "sdfkvjdfkjv" & vbCrLf & "dfsgkjhdfj" & vbCrLf & "dfkjbhhjsdbvcsdhjbvdhs" & vbCrLf & "dfksbvashjcvhjbc"
Dim str2() As String = str.Split(vbCrLf)
For Each s In str2
If s.Contains("YourString") Then
'add your line to txtbox
Else
'don't add your line to txtbox
End If
Next
Or You Can Use
TextFile = TextFile.Replace("You want to Delete","")
Related
When I process emails in a folder I get "Out of Memory" error.
Searching online I see many suggests to clear the memory, so I added code like below:
Set objItem = Nothing
Set objMailItem = Nothing
Redim arrLines(0)
Option Explicit
Private Sub btnStart_Click()
Dim StartDate As Date
Dim EndDate As Date
StartDate = DateValue("October 1, 2015")
EndDate = DateValue("January 28, 2023")
Call ProcessOrderEmails(StartDate, EndDate)
End Sub
Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
Dim objCurFolder As Folder
Dim objItem As Object
Dim objMailItem As MailItem
Dim nCSVFileNum As Integer
' Create the CSV file
nCSVFileNum = FreeFile
If Dir("E:\Temp\OrderStat.csv") <> "" Then
Kill ("E:\Temp\OrderStat.csv")
End If
Open "E:\Temp\OrderStat.csv" For Output Lock Write As #nCSVFileNum
' Get statistics
Set objCurFolder = Application.ActiveExplorer.CurrentFolder
For Each objItem In objCurFolder.Items
If TypeOf objItem Is MailItem Then
Set objMailItem = objItem
' Check if the mail is in the date range
If (objMailItem.SentOn >= StartDate) And (objMailItem.SentOn <= EndDate) Then
Select Case objMailItem.SenderEmailAddress
Case "automated#mycommerce.com"
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
End Select
End If
End If
' Set objItem to nothing to free memory
Set objItem = Nothing
Set objMailItem = Nothing
Next
' Close the file
Close nCSVFileNum
End Sub
Private Function ReplaceNewLine(strText As String, strNewLine As String) As String
ReplaceNewLine = Replace(strText, vbCrLf, strNewLine)
ReplaceNewLine = Replace(ReplaceNewLine, vbCr, strNewLine)
ReplaceNewLine = Replace(ReplaceNewLine, vbLf, strNewLine)
End Function
Private Function SplitLines(strText As String) As Variant
SplitLines = Split(ReplaceNewLine(strText, vbNewLine), vbNewLine)
End Function
' strEntryName should include :, like this RegNow OrderItemID:
Private Function GetEntryValue(strEntryLine As String, strEntryName As String, ByRef strEntryValue) As Boolean
Dim strLine As String
' Initialize result to False by default
GetEntryValue = False
' Parse the line
strLine = ReplaceNewLine(Trim(strEntryLine), "")
If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then
strEntryValue = Trim(Replace(strLine, strEntryName, "", 1, -1, vbTextCompare))
GetEntryValue = True
End If
End Function
Private Function ProcessRegNowOrderEmail(objMailItem As MailItem) As String
Dim arrLines() As String
Dim strLine As String
Dim strOrderID As String
Dim strProduct As String
Dim strProfit As String
Dim I As Integer
arrLines = SplitLines(objMailItem.Body)
For I = LBound(arrLines, 1) To UBound(arrLines, 1)
Call GetEntryValue(arrLines(I), "RegNow OrderItemID:", strOrderID)
Call GetEntryValue(arrLines(I), "Product Name:", strProduct)
Call GetEntryValue(arrLines(I), "Profit:", strProfit)
Next I
ProcessRegNowOrderEmail = "RegNow," & strOrderID & "," & strProduct & "," & strProfit
ReDim arrLines(0)
End Function
Sample email to be processed:
********** DO NOT REPLY TO THIS EMAIL **********
*** Transaction Identification ***
Date: 2017-03-14 02:14:14 (Pacific Standard Time)
RegNow OrderID: XXXXXX-XXXXX
RegNow OrderItemID: XXXXXX-XXXXX
*** Gift Information ***
Gift: no
Pickup: no
*** Product Information ***
Item #: #####-#
Product Name: My Product
Quantity: 1
Tax: 0.00 USD
Total: 199.95 USD
Profit: 189.15
The error is caused by the following line:
If InStr(1, strLine, strEntryName, vbTextCompare) > 0 Then
when strLine contains Japanese characters:
Address2: パティオたまプラーザ308
Searching online, I find similar posts:
[VBA][excel] Occurred error When Using 'Japanese - Katakana' in 'inStr'
https://social.msdn.microsoft.com/Forums/en-US/06df9b54-ad75-4c18-9577-84e52b6e03a1/how-can-i-use-the-japanese-for-instr-vba-?forum=exceldev
It is difficult to see how labels you are not interested in are processed.
This code will process specified labels only.
Option Explicit
Function ParseTextLinePair(strSource As String, strLabel As String)
' https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2007/dd492012(v=office.12)
Dim intLocLabel As Integer
Dim intLocCRLF As Integer
Dim intLenLabel As Integer
Dim strText As String
' locate the label in the source text
intLocLabel = InStr(strSource, strLabel)
intLenLabel = Len(strLabel)
If intLocLabel > 0 Then
intLocCRLF = InStr(intLocLabel, strSource, vbCrLf)
If intLocCRLF > 0 Then
intLocLabel = intLocLabel + intLenLabel
strText = Mid(strSource, intLocLabel, intLocCRLF - intLocLabel)
Else
intLocLabel = Mid(strSource, intLocLabel + intLenLabel)
End If
End If
ParseTextLinePair = Trim(strText)
End Function
Private Function ProcessRegNowOrderEmail_Label(objMailItem As MailItem) As String
Dim strOrderID As String
Dim strProduct As String
Dim strProfit As String
strOrderID = ParseTextLinePair(objMailItem.body, "RegNow OrderItemID:")
strProduct = ParseTextLinePair(objMailItem.body, "Product Name:")
strProfit = ParseTextLinePair(objMailItem.body, "Profit:")
ProcessRegNowOrderEmail_Label = "RegNow," & strOrderID & "," & strProduct & "," & strProfit
End Function
Replace
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
with
Print #nCSVFileNum, ProcessRegNowOrderEmail_Label(objMailItem)
Apparently memory allocated to objItem in a For Each cannot be freed.
Change to an indexed For Next so there is no objItem.
Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
Dim objCurFolder As Folder
Dim objMailItem As MailItem
Dim nCSVFileNum As Integer
' Create the CSV file
nCSVFileNum = FreeFile
If dir("E:\Temp\OrderStat.csv") <> "" Then
Kill ("E:\Temp\OrderStat.csv")
End If
Open "E:\Temp\OrderStat.csv" For Output Lock Write As #nCSVFileNum
' Get statistics
Set objCurFolder = Application.ActiveExplorer.currentFolder
Dim curFolderItems As Items
Set curFolderItems = objCurFolder.Items
Dim curFolderItemsCount As Long
curFolderItemsCount = curFolderItems.count
Dim i As Long
For i = 1 To curFolderItemsCount
If TypeOf curFolderItems(i) Is MailItem Then
Set objMailItem = curFolderItems(i)
With objMailItem
' Check if the mail is in the date range
If (.SentOn >= StartDate) And (.SentOn <= EndDate) Then
Select Case .senderEmailAddress
Case "automated#mycommerce.com"
Print #nCSVFileNum, ProcessRegNowOrderEmail(objMailItem)
End Select
End If
End With
' free memory
Set objMailItem = Nothing
End If
Next
' Close the file
Close nCSVFileNum
End Sub
Appears there is something else involved. With your original code using objItem I can generate a file with over 30,000 entries.
Unlikely this will be any better but rather than assigning objMailItem, you could use curFolderItems(i) directly.
Sub ProcessOrderEmails(StartDate As Date, EndDate As Date)
Dim objCurFolder As Folder
Dim nCSVFileNum As Integer
Dim pathFile As String
pathFile = "E:\Temp\OrderStat.csv"
' Create the CSV file
nCSVFileNum = FreeFile
Debug.Print nCSVFileNum
If dir(pathFile) <> "" Then
Kill pathFile
End If
Open pathFile For Output Lock Write As #nCSVFileNum
' Get statistics
Set objCurFolder = Application.ActiveExplorer.currentFolder
Dim curFolderItems As Items
Set curFolderItems = objCurFolder.Items
Dim curFolderItemsCount As Long
curFolderItemsCount = curFolderItems.count
Dim i As Long
Dim j As Long
' for testing the limit
'For j = 1 To Int(1000 / curFolderItemsCount) + 1
For i = 1 To curFolderItemsCount
If TypeOf curFolderItems(i) Is MailItem Then
Dim n As Long
n = n + 1
Debug.Print n
With curFolderItems(i)
' Check if the mail is in the date range
If (.SentOn >= StartDate) And (.SentOn <= EndDate) Then
'Select Case .senderEmailAddress
'Case "automated#mycommerce.com"
Print #nCSVFileNum, ProcessRegNowOrderEmail(curFolderItems(i))
'End Select
End If
End With
End If
Next
'Next
' Close the file
Close nCSVFileNum
End Sub
After testing for several times, I find out
For Japanese characters in TextBox1.Text, call InStr with vbTextCompare will cause "Out of memory":
nPos = InStr(1, TextBox1.Text, "Address2", vbTextCompare)
But with vbBinaryCompare, everything is fine:
nPos = InStr(TextBox1.Text, "Address2")
nPos = InStr(1, TextBox1.Text, "Address2")
nPos = InStr(1, TextBox1.Text, "Address2", vbBinaryCompare)
Thanks to all of your great helps!
I tried to get the number of lines of data in several CSV files in VBA.
Here is the code.
Sub Woo_Products()
Dim fso As New FileSystemObject
Dim flds As Folders
Dim fls As Files
Dim strText As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim extfind As String
Dim FilePath As String
Dim sLineOfText As String
On Error Resume Next
Workbooks.Open Filename:="F:\Work\scrape\" & "woocommerce-products.csv", UpdateLinks:=3
Set fls = fso.getfolder("C:\Users\star\Downloads").Files
k = 2
For Each f In fls
strText = f.Name
extfind = Right$(strText, Len(strText) - InStrRev(strText, "."))
If extfind = "csv" Then
FilePath = "C:\Users\star\Downloads\" & strText
Open FilePath For Input As #1
i = 0
Do Until EOF(1)
Line Input #1, sLineOfText
If sLineOfText <> "" Then i = i + 1
Loop
Close #1
End If
Next
Windows("woocommerce-products.csv").Activate
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
But I am getting the same count for each file.
Of course, each file has different lines of data.
Hope to help me for this.
If all you need is a line count, I would write a function to return the count.
Function getFileLineCount(FullFileName As String, Optional LineDelimiter As String = vbNewLine) As Long
Dim text As String
Dim fileNo As Integer, n As Long
fileNo = FreeFile
Open FullFileName For Input As #fileNo
Do Until EOF(1)
Line Input #1, text
n = n + 1
Loop
Close #fileNo
getFileLineCount = n
End Function
Another approach using FileSystemObject:
Public Function GetLineCount(ByVal Path As String) As Long
With CreateObject("Scripting.FileSystemObject")
GetLineCount = UBound(Split(.OpenTextFile(Path, 1).ReadAll, vbNewLine)) + 1
End With
End Function
You'll need to add the references (Tools --> References)
Microsoft Scripting Runtime
Microsoft VBScript Regular Expressions 5.5
This will count "Return & NewLine" characters in the file.
Private Function LineCount(ByVal PathFile As String) As Long
Dim sData As String
Dim oFile As New FileSystemObject
sData = oFile.OpenTextFile(PathFile, ForReading).ReadAll
Dim oRegX As New RegExp
oRegX.Pattern = "\r\n"
oRegX.Global = True
LineCount = oRegX.Execute(sData).Count + 1
Set oRegX = Nothing
Set oFile = Nothing
End Function
i = ActiveWorkbook.ActiveSheet.Cells(ActiveWorkbook.ActiveSheet.Rows.Count, 1).End(xlUp).Row
It's working so well.
I am very new to VBA. I keep on getting an error of type mismatch whenever the cancel/quit button in the dialogue box is clicked. The error appears on the Application.GetOpenFileName line. Does anyone know what is wrong here? I have tried several methods but none of them work :(
Thanks!
Here's my code:
Private Sub cmdBrowse_Click()
Application.ScreenUpdating = False
Dim i As Long, j As Long, iCheck As Long
Dim fname() As Variant
Dim wkbNameList As String, wkbNamePath As String
Dim win As Window
fname = Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True)
If fname = "False" Then
Exit Sub
End If
For i = LBound(fname) To UBound(fname)
workbooks.Open Filename:=fname(i)
wkbNameList = wkbNameList & workbooks(i + 1).Name & vbCrLf
wkbNamePath = wkbNamePath & fname(i) & " , "
Next i
function returns an array when files are selected, but returns a string when cancel/quit is selected
try this
Private Sub cmdBrowse_Click()
Application.ScreenUpdating = False
Dim i As Long, j As Long, iCheck As Long
Dim fname As Variant
Dim wkbNameList As String, wkbNamePath As String
Dim win As Window
fname = Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True)
If IsArray(fname) Then 'file selected
For i = LBound(fname) To UBound(fname)
Workbooks.Open Filename:=fname(i)
wkbNameList = wkbNameList & Workbooks(i + 1).Name & vbCrLf
wkbNamePath = wkbNamePath & fname(i) & " , "
Next i
ElseIf fname = "False" Then 'cancel/quit
Exit Sub
End If
End Sub
As pointed out by Kostas K. in the comments on h2so4's reply, the method returns boolean (False) when the dialog is cancelled, and array when a file is chosen.
I'd suggest trying this slight modification of h2so4's code:
Private Sub cmdBrowse_Click()
Application.ScreenUpdating = False
Dim i As Long, j As Long, iCheck As Long
Dim fname() As Variant
Dim wkbNameList As String, wkbNamePath As String
Dim win As Window
fname = Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True)
'the only option to get boolean is to have cancelled the dialog, which gives False for the variable
If VarType(fname) = vbBoolean Then
Exit Sub
Else
For i = LBound(fname) To UBound(fname)
workbooks.Open Filename:=fname(i)
wkbNameList = wkbNameList & workbooks(i + 1).Name & vbCrLf
wkbNamePath = wkbNamePath & fname(i) & " , "
Next i
End If
End Sub
'I ran into this problem working with multiselect as well
'Something like this will work
'The problem is [cancel] returns a Boolean instead of an array.. so we make it return an array
Dim fname(), fname_catcherror() As Variant
fname_catcherror = Array(Application.GetOpenFilename(filefilter:="Excel, *xlsx; *xlsm", MultiSelect:=True), True)
if VarType(fname_catcherror(0)) <> vbBoolean Then
fname = fname_catcherror(0)
'..code here
end if
Does anyone have an idea how to return parameter name in VBA?
This is what I have:
Sub Main()
Dim MyString As String
MyString = "Hello World"
MsgBox MyString
End Sub
It shows only "Hello World". I would like to have it "MyString says Hello World", but dynamically, not by entering
MsgBox "MyString says " & MyString
I would prefer something like
MsgBox ParamName(MyString) & " says " & MyString
but it actually won't work... Could anyone help?
I believe I have accomplished what you are looking to do here. However, please note that this will currently only work for your first parameter in a macro assigned to a Form control:
Step 1
Add the following code, adapted from here, to a new Module:
Public Function ExportModules(ModuleName As String) As String
Dim bExport As Boolean
Dim wkbSource As Excel.Workbook
Dim szSourceWorkbook As String
Dim szExportPath As String
Dim szFileName As String
Dim cmpComponent As VBIDE.VBComponent
''' The code modules will be exported in a folder named.
''' VBAProjectFiles in the Documents folder.
''' The code below create this folder if it not exist
''' or delete all files in the folder if it exist.
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Export Folder not exist"
Exit Function
End If
On Error Resume Next
Kill FolderWithVBAProjectFiles & "\*.*"
On Error GoTo 0
''' NOTE: This workbook must be open in Excel.
szSourceWorkbook = ActiveWorkbook.Name
Set wkbSource = Application.Workbooks(szSourceWorkbook)
If wkbSource.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to export the code"
Exit Function
End If
szExportPath = FolderWithVBAProjectFiles & "\"
Set cmpComponent = wkbSource.VBProject.VBComponents(ModuleName)
bExport = True
szFileName = cmpComponent.Name
''' Concatenate the correct filename for export.
Select Case cmpComponent.Type
Case vbext_ct_ClassModule
szFileName = szFileName & ".cls"
Case vbext_ct_MSForm
szFileName = szFileName & ".frm"
Case vbext_ct_StdModule
szFileName = szFileName & ".bas"
Case vbext_ct_Document
''' This is a worksheet or workbook object.
''' Don't try to export.
bExport = False
End Select
If bExport Then
''' Export the component to a text file.
cmpComponent.Export szExportPath & szFileName
''' remove it from the project if you want
'''wkbSource.VBProject.VBComponents.Remove cmpComponent
End If
ExportModules = szExportPath & szFileName
End Function
Function FolderWithVBAProjectFiles() As String
Dim WshShell As Object
Dim FSO As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("scripting.filesystemobject")
SpecialPath = WshShell.SpecialFolders("MyDocuments")
If Right(SpecialPath, 1) <> "\" Then
SpecialPath = SpecialPath & "\"
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = False Then
On Error Resume Next
MkDir SpecialPath & "VBAProjectFiles"
On Error GoTo 0
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = True Then
FolderWithVBAProjectFiles = SpecialPath & "VBAProjectFiles"
Else
FolderWithVBAProjectFiles = "Error"
End If
End Function
Step 2
Add the following code, adapted from answer #7 here, and from here, along with my own function, to a new module (it could be the same module as the first if preferred):
Public Function MyMacroInfo() As String
Dim MacroName$, SubName$, ModArr As Variant
Dim ModName As Object, strModName$, i&, j&
MacroName = ActiveSheet.Buttons(Application.Caller).OnAction
SubName = Application.Replace(MacroName, 1, Application.Search("!", MacroName), "")
ModArr = Array(0, 1, 2, 3)
For Each ModName In ActiveWorkbook.VBProject.VBComponents
For j = LBound(ModArr) To UBound(ModArr)
i = 0
On Error Resume Next
i = ModName.CodeModule.ProcStartLine(SubName, CLng(ModArr(j)))
Err.Clear
If i > 0 Then
strModName = ModName.Name
Exit For
End If
Next j
Next ModName
MyMacroInfo = strModName
End Function
Public Function GetParamName(ModulePath As String) As String
Dim text As String
Dim textline As String
Dim ParamStartLocation As Long
Dim ParamEndLocation As Long
Dim ParamLength As Long
Dim i As Long
Open ModulePath For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
ParamStartLocation = 0
For i = 1 To 3
ParamStartLocation = InStr(ParamStartLocation + 1, text, "Dim ")
Next i
ParamEndLocation = InStr(ParamStartLocation, text, " As ")
ParamLength = ParamEndLocation - ParamStartLocation
GetParamName = Left(Right(text, Len(text) - ParamStartLocation - 3), ParamLength - 4)
End Function
Step 3
Change your sub to the following:
Sub Main()
'--------Leave this section at the top of your sub---------
Dim strExportedModule As String
Dim strParamName As String
strExportedModule = ExportModules(MyMacroInfo)
strParamName = GetParamName(strExportedModule)
'-----------------Start your code here---------------------
Dim MyString As String
MyString = "Hello World"
MsgBox strParamName & " says " & MyString
End Sub
Step 4
Assign Main to a Form Button.
Notes
As noted above, this will only get the first parameter that you dimension in the macro assigned to the Form Button. If this is not acceptable, I'll have to take a look at it to see if it can be modified to meet your needs.
As Ron de Bruin notes on his site, you'll need to do the following:
In the VBE Editor set a reference to "Microsoft Visual Basic For
Applications Extensibility 5.3" and to "Microsoft Scripting Runtime"
and then save the file.
This code will export the module to a folder named "VBAProjectFiles" in your My Documents folder. If you happen to have a folder saved there with the same name (as unlikely as that is), it will delete all the files in that folder.
So i'm new to working with vba in access and i'm having trouble getting this code to work. What it is suppose to do is take a selected text file and read the original file into a list box. Then there is a second button that when pressed will convert the text file from a pipe delimited file into a tab delimited file and then show the changed file into a new listbox.
Option Compare Database
Option Explicit
Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End If
End Function
Private Sub Command0_Click()
Dim fdlg As Office.FileDialog
Dim pipe_file As Variant
Dim FileName As String
Dim fn As Integer
Dim varFile As Variant
Dim FilePath As String
Me.OrigFile.RowSource = ""
Me.ConvertFile.RowSource = ""
Me.FileName = ""
Me.FilePath = ""
FileName = ""
Set fdlg = Application.FileDialog(msoFileDialogFilePicker)
With fdlg
.AllowMultiSelect = False
.Title = "Select pipe delimited file"
.Filters.Clear
.Filters.Add "Text Files", "*.txt"
If .Show = True Then
For Each varFile In .SelectedItems
FileName = GetFilenameFromPath(varFile)
FilePath = varFile
Next varFile
Me.FileName = FileName
Me.FilePath = FilePath
fn = FreeFile
Open FileName For Input As #fn
Do While Not EOF(fn)
Line Input #fn, pipe_file
Me.OrigFile.AddItem pipe_file
Loop
Close #fn
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With
End Sub
Private Sub Convert_File_Click()
'ByVal OutputFile As String)'
On Error GoTo error1
Dim pipe_file As Variant
Dim ThisString As String
Dim NewString As String
Dim A As Integer
Dim InputFile As String
InputFile = Me.FilePath
Open InputFile For Input As #1
Const FileName = "c:\outputfile.txt"
Dim my_filenumber As Integer
my_filenumber = FreeFile
Open FileName For Output As #2
'Open OutputFile For Output As #2'
While Not EOF(1)
NewString = ""
Line Input #1, ThisString
For A = 1 To Len(ThisString)
If Mid(ThisString, A, 1) = "|" Then
NewString = NewString & Chr$(9)
Else
NewString = NewString & Mid(ThisString, A, 1)
End If
Next
Print #2, ThisString
Wend
Do While Not EOF(2)
Line Input #2, pipe_file
Me.ConvertFile.AddItem pipe_file
Loop
Close #2
Close #1
Exit Sub
error1:
Close #1
Close #2
End Sub
This is what i have so far now my issue is pertaining to the second button or Convert_File_Click() convertfile is the listbox i'm trying to update and filepath is a textbox that hold the filepath of the textfile that is selected.
Any help is appreciated, Thanks!
I haven't had a chance to aptly test this, but this is probably more in line of what you're looking for:
Private Sub Convert_File_Click()
On Error GoTo error_hander
Dim pipe_file As Variant
Dim ThisString As String
Dim NewString As String
Dim InputFile As String
Dim inputFileNo As Integer
Dim outputFileNo As Integer
Dim inputFileNo2 As Integer
Const FileName = "c:\outputfile.txt"
InputFile = Me.FilePath
inputFileNo = FreeFile
Open InputFile For Input As #inputFileNo
outputFileNo = FreeFile
Open FileName For Output As #outputFileNo
While Not EOF(inputFileNo)
Line Input #inputFileNo, ThisString
'Nix the FOR LOOP and use the Replace command instead. Less code and easier to understand
Print #outputFileNo, Replace(ThisString, "|", vbTab)
Wend
Close #outputFileNo
inputFileNo2 = FreeFile
Open FileName For Input As #inputFileNo2
Do While Not EOF(inputFileNo2)
Line Input #inputFileNo2, pipe_file
Me.ConvertFile.AddItem pipe_file
Loop
GoTo convert_file_click_exit
error_hander:
'Do some error handling here
convert_file_click_exit:
Close #inputFileNo
Close #outputFileNo
End Sub
Also, couldn't help but notice your GetFilenameFromPath routine. Consider this instead:
Public Function GetFilenameFromPath(ByVal strPath As String) As String
' Returns the rightmost characters of a string upto but not including the rightmost '\'
' e.g. 'c:\winnt\win.ini' returns 'win.ini'
'There's a couple of ways you could do this so it's not so cumbersome:
'1. The DIR command (will return the name of the file if it is a valid directory and file:
GetFilenameFromPath = Dir(strPath, vbNormal)
' OR
'2. InstrRev
Dim iFilePositionStart As Integer
iFilePositionStart = InStrRev(strPath, "\", -1, vbTextCompare)
GetFilenameFromPath = Mid$(strPath, iFilePositionStart + 1)
End Function
Okay so after spending some time researching it and a lot of time debugging i finally figured it out so i figured i'd post my results in case somebody else ever needs help with this
Function PipeToTab(ByVal OriginalText As String) As String
'Runs though current line of text stored in original text'
On Error GoTo error1
Dim ThisString As String, NewString As String, a As Integer
NewString = ""
For a = 1 To Len(OriginalText)
'checks to see if current char is white space and if it is removes it
If Mid(OriginalText, a, 1) = " " Then
'checks to see if current char is | and if it is changes it to char$(9) (tab)
ElseIf Mid(OriginalText, a, 1) = "|" Then
NewString = NewString & Chr$(9)
Else
NewString = NewString & Mid(OriginalText, a, 1)
End If
Next
PipeToTab = NewString
Exit Function
error1:
MsgBox (Err.Description)
End Function`
This is the function i came up with to convert a line of text from the text file from "|" to tabs as well as removing any additional white space.
`Private Sub Convert_File_Click()
On Error GoTo error1
Dim pipe_file As Variant
Dim ThisString As String
Dim a As Integer
Dim rfs, rts, InputFile, wfs, wts, OutputFile As Object
Dim InputFileName, OutputFileName, OriginalText, updatedText As String
' File initialization
'open the original source file and create the output file with the name desired from textbox.
InputFileName = Me.FilePath 'filepath is a textbox that holds the location
'and name of where you want the textfile to go
Set rfs = CreateObject("Scripting.FileSystemObject")
Set InputFile = rfs.GetFile(InputFileName)
'open the text streams
Set rts = InputFile.OpenAsTextStream(1, -2) 'Read
Set wts = OutputFile.OpenAsTextStream(8, -2) 'Append
'then put line into conversion function and get the updated text
'move onto the next line until EOF
While rts.AtEndofStream = False
OriginalText = rts.ReadLine 'read current line of file
If OriginalText <> Empty Then
updatedText = PipeToTab(OriginalText)
wts.WriteLine updatedText 'put updated text into newly created file(output file)
Else
End If
Wend`
'Output file clean up
wts.Close
'Input File clean up
rts.Close
End If
'clear out filestreams
Set OutputFile = Nothing
Set wfs = Nothing
Set wts = Nothing
Set InputFile = Nothing
Set rfs = Nothing
Set rts = Nothing
Exit Sub
error1:
' File Clean up
rts.Close
Set InputFile = Nothing
Set rfs = Nothing
Set rts = Nothing
'Output
wts.Close
Set OutputFile = Nothing
Set wfs = Nothing
Set wts = Nothing
MsgBox (Err.Description)
End Sub
This here is the button used to convert the text file. I used text streams and a line reader in order to send each line of the text file into the pipe to tab function.