I want to open a text file from my directory to find emails from a text. I use this code:

Public Sub makeEmailList()

Fname = Application.GetOpenFilename(MultiSelect:=True)

If Not IsArray(Fname) Then MsgBox "No File Selected", vbMsgBoxRtlReading, "": Exit Sub


Dim wbkExport As Workbook
Set wbkExport = Application.Workbooks.Add

wbkExport.Worksheets(1).Cells(1, 1).Select
Selection = "EMail"

r = 1

For K = LBound(Fname) To UBound(Fname)
    If Right(Fname(K), 4) = ".txt" Then
        Open Fname(K) For Input Access Read As #1
        
        While Not EOF(1)
        
            Line Input #1, WholeLine
            If InStr(WholeLine, "@") > 0 Then
                S = InStr(WholeLine, "<th>")
                e = InStr(WholeLine, "</th>")
                r = r   1
                wbkExport.Worksheets(1).Cells(r, "A") = Mid(WholeLine, S   4, e - S - 4)       
            End If
        Wend
        
    End If

Next K
Close #1
End Sub

when the name of all folders and sub folders that contains the text file, are English, everything is ok. but when I choose a file from a path that has a folder that it's name contains Persian characters (just this two characters: "ی" and "ک") it returns Error 76: path not Found.

In Persian we type "ی" as ChrW(1740) but vba uses arabic "ي" with ChrW(1610) instead and we type ChrW(1705) for "ک" but VBA Uses ChrW(1603). this is the reason.

The error occurs here:

Open Fname(K) For Input Access Read As #1
        

I used the replace function, above this line, to change characters but it did'nt work.

Fname(K) = Replace(Replace(Fname(K), ChrW(1610), ChrW(1740)),  ChrW(1603), ChrW(1705))

I checked the windows language and location setting on windows And Language setting in excel options, and it is ok.

thank you for your help.

CodePudding user response：

thank you so much my language settings are correct

 Fname = Application.GetOpenFilename(MultiSelect:=True)
    
 For K = LBound(Fname) To UBound(Fname)
     If Right(Fname(K), 4) = ".txt" Then
         Open Fname(K) For Input Access Read As #1
     End If

 Next K

I use this cod to open a text file if all folders name doesn't contain "ی" and "ک" every thing is ok.

CodePudding user response：

Open File When Non-English Letters in Path

• Instead of the Open statement, use the OpenTextFile method of the FileSystemObject object.

Public Sub MakeEmailList()
' Needs a reference to VBE->Tools->References->Microsoft Scripting Runtime

    Dim fPaths As Variant: fPaths = Application.GetOpenFilename(MultiSelect:=True)
    If Not IsArray(fPaths) Then MsgBox "No File Selected", vbMsgBoxRtlReading, "": Exit Sub
    
    Dim wbkExport As Workbook: Set wbkExport = Workbooks.Add(xlWBATWorksheet)
    Dim wsExport As Worksheet: Set wsExport = wbkExport.Worksheets(1)
    wsExport.Range("A1").Value = "EMail"
    Dim r As Long: r = 1

    ' Early binding needs a reference and has IntelliSense to easily learn.
    Dim fso As Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
    ' Or: Late binding needs no reference; no IntelliSense though.
    'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim fsoTextStream As Scripting.TextStream ' early binding...
    'Dim fsoTextStream As Object ' ... or late binding
    Dim fPath As String
    Dim fExtension As String
    Dim WholeLine As String
    Dim sPos As Long
    Dim ePos As Long
    Dim n As Long

    For n = LBound(fPaths) To UBound(fPaths)
        fPath = fPaths(n)
        'Debug.Print "Path: " & fPath
        fExtension = fso.GetExtensionName(fPath)
        If StrComp(fExtension, "txt", vbTextCompare) = 0 Then
            Set fsoTextStream = fso.OpenTextFile(fPaths(n), ForReading)
                Do While Not fsoTextStream.AtEndOfStream
                    'DoEvents
                    WholeLine = fsoTextStream.ReadLine
                    'Debug.Print "Line: " & WholeLine
                    If InStr(WholeLine, "@") > 0 Then
                        sPos = InStr(WholeLine, "<th>")
                        ePos = InStr(WholeLine, "</th>")
                        r = r   1
                        wsExport.Cells(r, "A") = Mid(WholeLine, sPos   4, ePos - sPos - 4)
                    End If
                Loop
            fsoTextStream.Close
        End If
    Next n

End Sub