Excel naar RTF

[Demeter]

Hoi,

Zit met een probleem waar ik al vaker tegen aan ben gelopen maar altijd om heen heb gewerkt.
Ik probeer data van Excel naar een rtf file te krijgen, inclusief cel opmaak (randen rondom)
Dit lukt met onderstaande code, via een omweg naar Word.
Maar als ik de rtf file direct open in Wordpad dan zie ik machine taal.
Als ik hem open in Word dan is alles ok.
Save ik hem weer handmatig vanuit Word dan is de rtf via Wordpad ook weer oke.
Ergens gaat er dus iets fout om via word in VBA naar rtf te saven, dit probleem heb ik vaker gehad, Word saved standaard in andere vorm naar rtf dan wordpad dat doet (Word geeft meer data mee dan nodig is volgens mij).

Weet een van jullie misschien een instelling/format voor save as rtf?

Sub Start_all_files()
Dim MyFolder As String
Dim myfile As String
Dim folderName As String
Dim teller As Long
Dim ws As Worksheet, strFile As String
Dim lastrow As Long
Dim oDoc As Object
Dim oWord As Object
Dim rRange1 As Range
Dim name_file As String

Application.ScreenUpdating = False

    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderName = .SelectedItems(1)
        End If
    End With
    
    myfile = Dir(folderName & "\*.lng")
    
    Set ws = ActiveWorkbook.Sheets(1)
    
    Do While myfile <> ""
        
        name_file = Left(myfile, Len(myfile) - 4)

        If myfile = "" Then Exit Do
        
        'Haal gegevens over naar Excel
        strFile = folderName & "\" & myfile
         
        With ws.QueryTables.Add(Connection:="TEXT;" & strFile, Destination:=ws.Range("A1"))
            .TextFileParseType = xlDelimited
            .TextFileOtherDelimiter = "="
            .Refresh
        End With
        
        lastrow = ws.Range("A65536").End(xlUp).Row
        
        'opmaak cellen
        With ws.Range("B1:C" & lastrow)
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
        End With

            
        myfile = Dir
        
        Set rRange1 = ws.Range("A1:B" & lastrow)
        Set oWord = CreateObject("Word.Application")
        Set oDoc = oWord.Documents.Add

        rRange1.Copy
        
        With oDoc
            .ActiveWindow.Selection.Paste
            [COLOR="#FF0000"].SaveAs Filename:=folderName & "\" & name_file & ".rtf", FileFormat:=wdOpenFormatRTF[/COLOR]
            .Close
        End With

        Set oDoc = Nothing
        Set rRange1 = Nothing
        
    Loop
    
    oWord.Quit
    Set oWord = Nothing
    
   
Application.ScreenUpdating = True

End Sub

Alvast bedankt

grt.
Demeter