How to write a data to a text file (VBA)

[Rhodie72]

I need to write data to a text file as a data steam
I have written preliminary code to capute data in a spreadsheet but the ultimate goal is to write the data direct to a text file without using a spreadsheet.

currently the spreadsheet is just to verify that the data is being captured correctly but it needs to be written to an array and then output as a text file with a line that is the command for an AutoCAD script.
The source data

SOP1

184320.468

398332.116

77,135

SOP2

184324.959

398335.356

77,135

SOP3

184369.416

398248.340

77,135

SOP4

184317.345

398251.648

77,135

SOP1.5

184310.358

398252.072

77,135

SOP1.6

184311.268

398267.045

77,135

SOP1.7

184318.255

398266.620

77,135

SOP2.1

184356.47

398057.478

77,135

SOP2.2

184304.218

398060.209

77,135

SOP2.3

184306.115

398096.166

77,135

SOP2.4

184308.803

398099.982

77,135

SOP2.5

184309.881

398117.917

77,135

SOP2.6

184307.445

398121.375

77,135

SOP3.1

184357.481

398102.259

77,135

SOP3.2

184357.237

398098.266

77,135

SOP3.3

184311.084

398104.783

77,135

SOP3.4

184310.867

398100.789

77,135

So far it produces this table

SOP1	184320.468,398332.116
SOP2	184324.959,398335.356
SOP3	184369.416,398248.34
SOP4	184317.345,398251.648
SOP1.5	184310.358,398252.072
SOP1.6	184311.268,398267.045
SOP1.7	184318.255,398266.62
SOP2.1	184356.47,398057.478
SOP2.2	184304.218,398060.209
SOP2.3	184306.115,398096.166
SOP2.4	184308.803,398099.982
SOP2.5	184309.881,398117.917
SOP2.6	184307.445,398121.375
SOP3.1	184357.481,398102.259
SOP3.2	184357.237,398098.266
SOP3.3	184311.084,398104.783
SOP3.4	184310.867,398100.789

The data ouput format required for "MyFile.scr"

PLINE


184320.468,398332.116
184324.959,398335.356
184369.416,398248.34
184317.345,398251.648
184310.358,398252.072
184311.268,398267.045
184318.255,398266.62
184356.47,398057.478
184304.218,398060.209
184306.115,398096.166
184308.803,398099.982
184309.881,398117.917
184307.445,398121.375
184357.481,398102.259
184357.237,398098.266
184311.084,398104.783
184310.867,398100.789

The code so far..

Sub Adjust_ColWidth()
'
' Adjust_ColWidth Macro
' Autofit column width
'

'
    Columns("A:A").EntireColumn.AutoFit
End Sub
Public Sub Delete_Blanks()
'
' Delete_Blanks Macro
' Deletes blanks in selection
'

'
    With Selection
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
    'Application.CutCopyMode = False
End Sub
Sub Reorder_Data()
'
' Reorder_Data Macro
' Reorders data secions to correct places
'
Dim N
'
    Run "Adjust_ColWidth"
    Run "Delete_Blanks"
    Range("A1").Select
    Run "Arrange_SOP_Data"
    With Selection
        .Copy
        N = .Count - 1
        MsgBox "There are " & N & " lines of data to export", vbInformation, "Data Check"
    End With
    Application.CutCopyMode = False
'   Export dataset to script file for AutoCAD
End Sub
Public Sub Delete_cells_up()
'
' Delete_cells_up Macro
' Deletes empty cells
'

'
    With Selection
        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        .End(xlUp).Select
    End With
End Sub

Public Sub Arrange_SOP_Data()
    Dim SOP_Data As Variant, X As Variant, Y As Variant

    Do Until Left(ActiveCell.Offset(1, 0).Value, 3) = ""
        If Left(ActiveCell.Value, 3) = "SOP" Then
            X = ActiveCell.Offset(1, 0).Text: Y = ActiveCell.Offset(2, 0).Text
            SOP_Data = Array(X, ",", Y)
            With ActiveCell
                .Offset(0, 1).Value = SOP_Data(0) & SOP_Data(1) & SOP_Data(2)
                Range(.Offset(1, 0), .Offset(3, 0)).EntireRow.Delete
                .Offset(1, 0).Select
            End With
        Else
            Stop
            
            Do Until Left(ActiveCell.Value, 3) = "SOP"
                ActiveCell.Offset(1, 0).Select
            Loop
            If Left(ActiveCell.Offset(1, 0).Value, 3) <> "SOP" Then
                X = ActiveCell.Offset(1, 0).Value: Y = ActiveCell.Offset(2, 0).Value
                SOP_Data = Array(X, ",", Y)
            End If
        End If
    Loop
    
    With Range("B1", ActiveCell.Offset(-1, 1))
        .Select
        Y = .Count
        .EntireColumn.AutoFit
        MsgBox Y
    End With
End Sub

My aim is literally to capture the reordered data of co-ordinates add the command to the first output, add a new line, append rthe file with each pair of cordinates then close the file.
Anybody up for this task to help out? The person who does this will discover what impact they have had on a major construction project, so there's a bragging right attached.

 

[Artik]

I don't know what end-of-line character is accepted in *.scr file. I used vbCrLf. If it has to be different, try changing it to vbCr or vbLf. Also adjust the paths and file names.

Sub AAA()
    Dim v As Variant
    Dim i As Long
    Dim strOut As String
    
    Const EndOfLine As String = vbCrLf 'or vbCr or vbLf
    
    v = TakeFromFile("d:\Test\InputFileName.txt")
    
    strOut = "PLINE" & EndOfLine
    
    For i = 0 To UBound(v) Step 8
        strOut = strOut & (v(i + 2) & "," & v(i + 4) & EndOfLine)
    Next i
    
    strOut = Left(strOut, Len(strOut) - Len(EndOfLine))
    
    Call WriteToFile("d:\Test\MyFile.scr", strOut)
    
    MsgBox "Done"
End Sub


Function TakeFromFile(strFilename As String) As Variant
    Dim iFn As Integer
    Dim strFileContent As String
    Dim varrTmp As Variant

    iFn = FreeFile

    Open strFilename For Input As #iFn
    strFileContent = Input(LOF(iFn), iFn)
    Close #iFn

    varrTmp = Split(strFileContent, vbCrLf)

    TakeFromFile = varrTmp
End Function


Sub WriteToFile(FileName As String, Data As String)
    Dim iFn As Integer
    
    iFn = FreeFile
    
    Open FileName For Output Access Write As #iFn
            
    Print #iFn, Data
    
    Close #iFn

End Sub

Artik

 

[rlv01]

Your code for Sub Reorder_Data() assumes that the data to export has already been selected . This rewrite assumes that the export data will be contained in the 2nd column of that selection. If that is not the case, you many need to tweak it. You will also need to edit your own value for variable ExportFolder.

Sub Reorder_Data()
    '
    ' Reorder_Data Macro
    ' Reorders data secions to correct places
    '
    Dim N
    Dim ExportRange As Range, R As Range
    Dim ExportFolder As String, FilePath As String, TextLine As String, Msg As String
    Dim FNumW As Integer
    
    Run "Adjust_ColWidth"
    Run "Delete_Blanks"
    Range("A1").Select
    Run "Arrange_SOP_Data"
    
    'Export dataset to script file for AutoCAD
    With Selection
        '.Copy
        Set ExportRange = .Resize(, 1).Offset(0, 1)
        N = .EntireRow.Count ' - 1
    End With
    
    Msg = "There are " & N & " lines of data selected for export" & vbCr & vbCr & "Export Data?"
    
    If ExportRange.Rows.Count > 1 Then
        Select Case MsgBox(Msg, vbYesNo Or vbQuestion, "Export Range: " & ExportRange.Address)
            Case vbYes
                ExportFolder = VBA.CurDir               '<---- CurDir is a placeholder. Edit this line to define folder for .scr file
                FilePath = ExportFolder & "\MyFile.scr"
                FNumW = FreeFile
                Open FilePath For Output Access Write As #FNumW    ' Open text file for write
                For Each R In ExportRange
                    TextLine = Trim(R.Value)
                    Print #FNumW, TextLine                        ' Write to output file
                Next R
                Close #FNumW                                      ' Close file.
            Case vbNo
                ' Do nothing
        End Select
    Else
        MsgBox "More than one line must be selected for export"
    End If
    Application.CutCopyMode = False
End Sub

 

[Rhodie72]

Thanks guys. Will teat in the morning

 

[Rhodie72]

Your code for Sub Reorder_Data() assumes that the data to export has already been selected . This rewrite assumes that the export data will be contained in the 2nd column of that selection. If that is not the case, you many need to tweak it. You will also need to edit your own value for variable ExportFolder.

Sub Reorder_Data()
    '
    ' Reorder_Data Macro
    ' Reorders data secions to correct places
    '
    Dim N
    Dim ExportRange As Range, R As Range
    Dim ExportFolder As String, FilePath As String, TextLine As String, Msg As String
    Dim FNumW As Integer
   
    Run "Adjust_ColWidth"
    Run "Delete_Blanks"
    Range("A1").Select
    Run "Arrange_SOP_Data"
   
    'Export dataset to script file for AutoCAD
    With Selection
        '.Copy
        Set ExportRange = .Resize(, 1).Offset(0, 1)
        N = .EntireRow.Count ' - 1
    End With
   
    Msg = "There are " & N & " lines of data selected for export" & vbCr & vbCr & "Export Data?"
   
    If ExportRange.Rows.Count > 1 Then
        Select Case MsgBox(Msg, vbYesNo Or vbQuestion, "Export Range: " & ExportRange.Address)
            Case vbYes
                ExportFolder = VBA.CurDir               '<---- CurDir is a placeholder. Edit this line to define folder for .scr file
                FilePath = ExportFolder & "\MyFile.scr"
                FNumW = FreeFile
                Open FilePath For Output Access Write As #FNumW    ' Open text file for write
                For Each R In ExportRange
                    TextLine = Trim(R.Value)
                    Print #FNumW, TextLine                        ' Write to output file
                Next R
                Close #FNumW                                      ' Close file.
            Case vbNo
                ' Do nothing
        End Select
    Else
        MsgBox "More than one line must be selected for export"
    End If
    Application.CutCopyMode = False
End Sub

This is a workable solution. I would like to be able to open a file dialog box to grapically locate where the file is to be written. Every file has to be written to a different folder and all of them are not on my local machine.

 

[Rhodie72]

I don't know what end-of-line character is accepted in *.scr file. I used vbCrLf. If it has to be different, try changing it to vbCr or vbLf. Also adjust the paths and file names.

Sub AAA()
    Dim v As Variant
    Dim i As Long
    Dim strOut As String
   
    Const EndOfLine As String = vbCrLf 'or vbCr or vbLf
   
    v = TakeFromFile("d:\Test\InputFileName.txt")
   
    strOut = "PLINE" & EndOfLine
   
    For i = 0 To UBound(v) Step 8
        strOut = strOut & (v(i + 2) & "," & v(i + 4) & EndOfLine)
    Next i
   
    strOut = Left(strOut, Len(strOut) - Len(EndOfLine))
   
    Call WriteToFile("d:\Test\MyFile.scr", strOut)
   
    MsgBox "Done"
End Sub
[QUOTE="Artik, post: 6194718, member: 218006"]
I don't know what end-of-line character is accepted in *.scr file. I used vbCrLf. If it has to be different, try changing it to vbCr or vbLf. Also adjust the paths and file names.
[CODE=vba]
Sub AAA()
    Dim v As Variant
    Dim i As Long
    Dim strOut As String
   
    Const EndOfLine As String = vbCrLf 'or vbCr or vbLf
   
    v = TakeFromFile("d:\Test\InputFileName.txt")
   
    strOut = "PLINE" & EndOfLine
   
    For i = 0 To UBound(v) Step 8
        strOut = strOut & (v(i + 2) & "," & v(i + 4) & EndOfLine)
    Next i
   
    strOut = Left(strOut, Len(strOut) - Len(EndOfLine))
   
    Call WriteToFile("d:\Test\MyFile.scr", strOut)
   
    MsgBox "Done"
End Sub


Function TakeFromFile(strFilename As String) As Variant
    Dim iFn As Integer
    Dim strFileContent As String
    Dim varrTmp As Variant

    iFn = FreeFile

    Open strFilename For Input As #iFn
    strFileContent = Input(LOF(iFn), iFn)
    Close #iFn

    varrTmp = Split(strFileContent, vbCrLf)

    TakeFromFile = varrTmp
End Function


Sub WriteToFile(FileName As String, Data As String)
    Dim iFn As Integer
   
    iFn = FreeFile
   
    Open FileName For Output Access Write As #iFn
           
    Print #iFn, Data
   
    Close #iFn

End Sub

Artik

Function TakeFromFile(strFilename As String) As Variant
Dim iFn As Integer
Dim strFileContent As String
Dim varrTmp As Variant

iFn = FreeFile

Open strFilename For Input As #iFn
strFileContent = Input(LOF(iFn), iFn)
Close #iFn

varrTmp = Split(strFileContent, vbCrLf)

TakeFromFile = varrTmp
End Function


Sub WriteToFile(FileName As String, Data As String)
Dim iFn As Integer

iFn = FreeFile

Open FileName For Output Access Write As #iFn

Print #iFn, Data

Close #iFn

End Sub[/CODE]
Artik
[/QUOTE]

I like where this is going but your code is working with this data from a text file whereas it is in the spreadsheet:

SOP1

184320.468

398332.116

77,135

SOP2

184324.959

398335.356

77,135

SOP3

Which doesn't help

Maybe I need to explain deeper.
I use Google translate to capture the data by camera; it then gets pasted into Whatsapp and sent to my work account. I open whatsapp on my computer, copy & Paste the data directly into Excel (as above). Why? This method allows me to capture the data from both digital and paper sources and deliver in the same format every time.
The VBA script is to collate the correct elements into co-ordinates but disregard irrelevant info.

The PLINE command is for AutoCAD, then a new empty line followed by coordinates. Drag & drop this script file into AutoCAD and it then draws the line to each coordinate in milliseconds. The entire process of data capture is massively reduced in time and that's saving about £12000 an hour in client costs.

 

[Sektor]

What format your original data is in?

 

[Rhodie72]

What format your original data is in?

a picture. It could be given to me in any format, but my method will always be consistent in exporting the correct data 100% of the time. It will always appear either on a screen or on paper in every drawing. The key data extaction is the X,Y co-ordinates. There are over 15,000 of these tables to collate and each coordinate has 21 charaters, which means millions of characters. We do not have 5.2 years to do this on this project. I got about 10 days at best.

 

[Rhodie72]

Maybe this picture will give a learer understanding of what I want VBA to achieve...

 

[rlv01]

I would like to be able to open a file dialog box to grapically locate where the file is to be written.

In Sub Reorder_Data() Replace this line

ExportFolder = VBA.CurDir               '<---- CurDir is a placeholder. Edit this line to define folder for .scr file

with this one

ExportFolder = GetFolder(CurDir)  '<--- Edit to suit.

Include this function.

Function GetFolder(strPath As String) As String
    Dim fldr As FileDialog
    Dim sItem As String

    strPath = Trim(strPath)
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a folder to save the file in"
        .AllowMultiSelect = False
        Do While Right(strPath, 1) = "\"
            strPath = Left(strPath, Len(strPath) - 1)
        Loop
        .InitialFileName = strPath & "\"              '.InitialFileName always needs to end with a backslash "\"
        .ButtonName = "Select"
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function