Open txt-file after Macro creating it

[elgato74]

Hello


I have a macro that creates a txt-file and saves it.

How can I have the macro open that txt-file once it created and saved it ?

Sub ExportToTextFile()
    Dim a       As Variant
    Dim s       As String
    Dim r       As Range
    Dim rng     As Range
    Dim C       As Range
    Dim i       As Long
    Dim k       As Long
    Dim cl      As Long

    ReDim a(1 To 1)
    s = "C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\"
    cl = 25
    k = 1

    For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
        If i = 3 Then Set r = Cells(i, 1)

        If Cells(i, 1).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then
            ReDim Preserve a(1 To k)
            a(k) = "c:\(" & Cells(1, cl).Value & ").printer"
            Set rng = Range(r, Cells(i, 1))

            For Each C In rng
                k = k + 1
                ReDim Preserve a(1 To k)
                a(k) = CStr(s & C.Value & ".jpg")
            Next C

            Set r = Cells(i + 1, 1)
            cl = cl + 1: k = k + 1
        End If
    Next i

    ArrayToTextFile a, "C:\Users\User\Documents\Spaces\TD1\" & "\Print.job"

    MsgBox "Done...", 64
End Sub

Thanks !

[YasserKhalil]

Hello
Try this method

Sub Open_Text_File_Using_Shell()
    Dim o       As Object
    Dim s       As String

    Set o = CreateObject("Shell.Application")
    s = ThisWorkbook.Path & "\Sample.txt"
    o.Open (s)
End Sub

[elgato74]

Check this screenshot:

Screenshot 2017-09-18 13.51.04.png


You notice those little "o" in Column B. These "o" mark Black&White items.

The macro that you wrote a few weeks ago would need to be extended with a feature, that, whenever there is an item with an "o" in B, there should be the following line written to the text file before that:

C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\192sw.prs

and after that, the line

C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\192.prs

These are Printer settings, so it switches the printer's settings to black&white, and then back to normal.

I will attach a sample text file, so you can see.

[elgato74]

+++ deleted +++

[elgato74]

Hi YasserKahlil,

thanks for that. Did you get my PM ?

The above code needs to be extended with a feature, can you help ?

[YasserKhalil]

Hello
Try this code

Sub ExportToTextFile()
    Dim a       As Variant
    Dim s       As String
    Dim r       As Range
    Dim rng     As Range
    Dim c       As Range
    Dim i       As Long
    Dim k       As Long
    Dim cl      As Long

    ReDim a(1 To 1)
    s = "C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\"
    cl = 25
    k = 1

    For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
        If i = 3 Then Set r = Cells(i, 1)

        If Cells(i, 1).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then
            ReDim Preserve a(1 To k)
            a(k) = "c:\(" & Cells(1, cl).Value & ").printer"
            Set rng = Range(r, Cells(i, 1))

            For Each c In rng
                If c.Offset(, 1).Value = "o" And c.Offset(-1, 1).Value <> "o" Then
                    k = k + 1
                    ReDim Preserve a(1 To k)
                    a(k) = CStr(s & Cells(1, cl).Value & "sw.prs")
                End If
                
                k = k + 1
                ReDim Preserve a(1 To k)
                a(k) = CStr(s & c.Value & ".jpg")
                
                If c.Offset(, 1).Value = "o" And c.Offset(1, 1).Value <> "o" Then
                    k = k + 1
                    ReDim Preserve a(1 To k)
                    a(k) = CStr(s & Cells(1, cl).Value & ".prs")
                End If
            Next c

            Set r = Cells(i + 1, 1)
            cl = cl + 1: k = k + 1
        End If
    Next i
    
    ArrayToTextFile a, "C:\Users\User\Documents\Spaces\TD1" & "\Print.txt"

    MsgBox "Done...", 64
End Sub

Function ArrayToTextFile(a, strPath)
    Const forWriting = 2

    Dim fso, writer
    Dim i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set writer = fso.OpenTextFile(strPath, forWriting, True)

    For i = LBound(a) To UBound(a)
        writer.writeline a(i)
    Next i

    writer.Close
End Function

[elgato74]

I just discovered one minor thing.

It would be best to put the line

C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\192.prs

to always start with printers' default settings, unless the first item is marked with "o" - then the *sw.prs should appear.

Everything else should remain the same.

[elgato74]

Perfect !! I need to test it some more, but it seems to work really well. Thank you!

[YasserKhalil]

I don't get the last point. Can you attach some of your expected output?

[elgato74]

Hello


Yes, I need to put the "normal" .prs in front of each batch, like shown above !

Can you do this for me ?

[elgato74]

here is the example

192.prs is the normal printer settings file for color prints
192sw.prs is the black&white printer settings file for the black&white prints

If the last item for a printer is black&white, the printer stays that way.

But I just noticed, that if the last item is marked with the "o" and the macro puts the 192sw.prs in front of it, it also puts a 192.prs after it. So all should be good.

My idea was to put the normal printer setting file in front of each printer like this:


c:\(194).printer
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\194.prs
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\ASH-1P.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\DIS-4LP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\EHZ-4LP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\DRK-3P.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\BEZ-MFP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\ACR-MFP.jpg

c:\(196).printer
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\196.prs
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\BMC-1K.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Magic Cat 1K.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Roulette Pano.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Ali MFP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Bulli V3 MFP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\FCQ-MFP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\CFP-5P.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\ETI-MFP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\ALK-Pano.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\DTB-3P.jpg

c:\(200).printer
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\200.prs
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\BLS-4erP.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\200sw.prs
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Marilyn V8 3P.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Pacino 3P.jpg
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\200.prs
C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\Venice V4 1P.jpg

[elgato74]

great, that looks right !

I will test it tomorrow

Have a good evening, and thank you again!

[YasserKhalil]

Give this a try

Sub ExportToTextFile()
    Dim a       As Variant
    Dim s       As String
    Dim r       As Range
    Dim rng     As Range
    Dim c       As Range
    Dim i       As Long
    Dim k       As Long
    Dim cl      As Long

    ReDim a(1 To 1)
    s = "C:\Dokumente und Einstellungen\Felix\Eigene Dateien\PRODUCTION\"
    cl = 25
    k = 1

    For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row
        If i = 3 Then Set r = Cells(i, 1)

        If Cells(i, 1).Borders(xlEdgeBottom).LineStyle <> xlLineStyleNone Then
            ReDim Preserve a(1 To k)
            a(k) = "c:\(" & Cells(1, cl).Value & ").printer"
            Set rng = Range(r, Cells(i, 1))
            k = k + 1
            ReDim Preserve a(1 To k)
            a(k) = s & Cells(1, cl).Value & ".prs"
            
            For Each c In rng
                If c.Offset(, 1).Value = "o" And c.Offset(-1, 1).Value <> "o" Then
                    k = k + 1
                    ReDim Preserve a(1 To k)
                    a(k) = CStr(s & Cells(1, cl).Value & "sw.prs")
                End If
                
                k = k + 1
                ReDim Preserve a(1 To k)
                a(k) = CStr(s & c.Value & ".jpg")
                
                If c.Offset(, 1).Value = "o" And c.Offset(1, 1).Value <> "o" Then
                    k = k + 1
                    ReDim Preserve a(1 To k)
                    a(k) = CStr(s & Cells(1, cl).Value & ".prs")
                End If
            Next c

            Set r = Cells(i + 1, 1)
            cl = cl + 1: k = k + 1
        End If
    Next i
    
    ArrayToTextFile a, "C:\Users\User\Documents\Spaces\TD1" & "\Print.txt"

    MsgBox "Done...", 64
End Sub

Function ArrayToTextFile(a, strPath)
    Const forWriting = 2

    Dim fso, writer
    Dim i As Long

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set writer = fso.OpenTextFile(strPath, forWriting, True)

    For i = LBound(a) To UBound(a)
        writer.writeline a(i)
    Next i

    writer.Close
End Function

[elgato74]

Works great ! Thanks !

[YasserKhalil]

You're welcome. Glad I can offer some help