Dim DicFolders As Variant
Private Sub ExportFormat(format As String)
    Dim ArrFileName() As String, ArrLan() As String, i&
    Dim sheetName As String, sheetActive As Variant, m&, lIndex As Long, inteval&
    On Error Resume Next
    sheetName = format + "Language.xls"
    Workbooks.Add
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" + sheetName, True
    ArrFileName = ExtractFileName(ThisWorkbook.Path, ".pas")
    Windows(sheetName).Activate
    Set sheetActive = ActiveSheet
    sheetActive.Cells(1, 1) = "FileName"
    sheetActive.Cells(1, 2) = "FilePath"
    sheetActive.Cells(1, 3) = "Information"
    lIndex = 2
    inteval = 2
    For i = LBound(ArrFileName) To UBound(ArrFileName)
        If (ArrFileName(i) <> "") Then
            strText = ReadText(ArrFileName(i), format)
            ArrLan = FindString(strText, "frmLan.GetLanStr\((.*\s.*\s.*\s.*)\)")
         ' save result to excel
         For m = LBound(ArrLan) To UBound(ArrLan)
            If m = 0 Then
                sheetActive.Cells(lIndex, 1) = Right(ArrFileName(i), Len(ArrFileName(i)) - InStrRev(ArrFileName(i), "\"))
                sheetActive.Cells(lIndex, 2) = ArrFileName(i)
            End If
            sheetActive.Cells(m + lIndex, 3) = ArrLan(m)
         Next m
         lIndex = lIndex + m + inteval
        End If
    Next i
End Sub
Private Sub btnExport_Click()
   ExportFormat ("UTF-8")
End Sub
Sub btnExportGB_Click()
   ExportFormat ("GB2312")
End Sub
'FilePath:Current File Path
'FileFilter:suffix such as .pas,.txt
' return : array of string
Function ExtractFileName(ByVal FilePath As String, Optional ByVal FileFilter As String = "*.*") As String()
Dim i&, n&, Mypath$, Arr() As String, strIndex As String
On Error Resume Next
    Set DicFolders = CreateObject("Scripting.Dictionary")
    DicFolders.Add (FilePath & "\"), ""
    i = 0
    Do While i < DicFolders.Count
        ke = DicFolders.keys
        Filename = Dir(ke(i), vbDirectory)
            Do While Filename <> ""
                If Filename <> "." And Filename <> ".." Then
                    If (GetAttr(ke(i) & Filename) And vbDirectory) = vbDirectory Then
                        DicFolders.Add (ke(i) & Filename & "\"), ""
                    End If
                End If
                Filename = Dir
            Loop
        i = i + 1
    Loop
  i = 0
'**********************************************************************************
        For Each ke In DicFolders.keys
            MyFliename = Dir(ke)
            Do While MyFliename <> ""
               strIndex = Right(MyFliename, 4)
               If strIndex = FileFilter Then
                    ReDim Preserve Arr(i)
                    Arr(i) = ke & MyFliename
                    i = i + 1
               End If
                MyFliename = Dir
            Loop
        Next
    ExtractFileName = Arr

End Function
' Description:read the txt file and return as as string
' FilePath:the absolute path of the file
' strFormat:the text format such as UTF-8,GB2312
' Return an String
Function ReadText(FilePath As String, strFormat As String) As String
    'Dim fso As Variant, f As Variant
    'Set fso = CreateObject("Scripting.FileSystemObject")
    'Set f = fso.OpenTextFile(FilePath)
    'ReadText = f.ReadAll
    Dim st As Variant
    Set st = CreateObject("ADODB.Stream")
    st.Type = 2
    st.Mode = 3
    st.Open
    st.LoadFromFile FilePath
    st.Charset = strFormat
    ReadText = st.ReadText
    st.Close
End Function
'Description:Find the strings that match with the Regular Format
'strText:string to be find
'RegFormat:Regular expressions
'return as an array of string
Function FindString(strText As String, Optional ByVal RegFormat As String = "*.*") As String()
    Dim Reg As Variant, m As Variant, Arr() As String, n&
    Set Reg = CreateObject("vbScript.RegExp")
    If strText <> "" Then
        Reg.Pattern = RegFormat
        Reg.Global = True
        Reg.IgnoreCase = True
        Reg.MultiLine = False
        ReDim Preserve Arr(1)
        For Each m In Reg.Execute(strText)
            n = n + 1
            ReDim Preserve Arr(n)
            Arr(n) = m
        Next
    End If
    FindString = Arr
End Function