Public Sub ParserASX_M3U()
'Основная процедура парсинга файлов ASX, m3u8
Dim i As Long, x As Long, n As Long
Dim tmp, temp
Dim arr1(), arr2()
Dim strTemp As String
' Получить коллекцию фалов для обработки.
' Используем внешнюю функцию диалог пользователя открыть файл, _
дает возможность выбора (обработки) как одного так и всех файлов в папке.
Dim objFilesCollection As Collection
Set objFilesCollection = GetCollectionFilesDialog
If objFilesCollection.Count = 0 Then Exit Sub
' Перебор коллекции поиск фалов ASX и m3u
Dim objASXCollection As New Collection
Dim objM3UCollection As New Collection
For Each tmp In objFilesCollection
If tmp Like "*.asx" Then
objASXCollection.Add tmp
ElseIf tmp Like "*.m3u*" Then
objM3UCollection.Add tmp
Else
End If
Next tmp
Set objFilesCollection = Nothing
' Работаем с файлами ASX
' Считsваем данные файла внешней функцией
If objASXCollection.Count > 0 Then
arr1 = GetCollectionASXfileText(objASXCollection)
If LBound(arr1) > 0 Then
arr1(1, 1) = "TITLE": arr1(1, 2) = "HREF"
' Выгружаем данные в новую книгу без сохранения
Call CreateEXCELfile(arr1, "ASX files", 0)
End If
End If
' Работаем с файлами m3u8
' Считsваем данные файла внешней функцией
If objM3UCollection.Count > 0 Then
For Each tmp In objM3UCollection
strTemp = CreateObject("Scripting.FileSystemObject").GetFileName(tmp)
arr2 = GetCollectionM3UfileText(tmp)
If LBound(arr2) > 0 Then
' Выгружаем данные в новую книгу без сохранения _
для каждого файла создается отдельная новая книга
Call CreateEXCELfile(arr2, strTemp, 1)
End If
Next
End If
Set objASXCollection = Nothing
Set objM3UCollection = Nothing
Erase arr1: Erase arr2
End Sub
Private Sub CreateEXCELfile(arrTemp, strNameSht As String, byteDataType As Byte)
''' ЗАГРУЖАЕМ ДАННЫЕ В СОЗДАННУЮ КНИГУ И РАБОТАЕМ С НЕЙ
' byteDataType - тип загружаемых данных (0 = массив файлов ASX, 1 = массив файлов m3u8)
Dim oExcelFile As Object
Dim iMaxRow As Long, iMaxClmn As Long
Dim i As Long, n As Long
iMaxRow = UBound(arrTemp, 1)
iMaxClmn = UBound(arrTemp, 2)
Workbooks.Add -4167 '=xlWBATWorksheet
''' Cоздаем новую книгу с одним листом
With CreateObject("Excel.Sheet"): Set oExcelFile = ActiveWorkbook: End With
With oExcelFile
ActiveSheet.Name = strNameSht
With .Sheets(strNameSht)
''' Формат ширин полей
If byteDataType = 0 Then
For Each oVl In .Range(.Cells(1, 1), .Cells(1, 1).Offset(, iMaxClmn - 1))
Select Case oVl.Column
Case Is = 1: oVl.ColumnWidth = 30: Case Is = 2: oVl.ColumnWidth = 145
End Select
Next
ElseIf byteDataType = 1 Then
For Each oVl In .Range(.Cells(1, 1), .Cells(1, 1).Offset(, iMaxClmn - 1))
Select Case oVl.Column
Case Is = 1: oVl.ColumnWidth = 15: Case Is = 2: oVl.ColumnWidth = 25
Case Is = 3: oVl.ColumnWidth = 45: Case Is = 4: oVl.ColumnWidth = 45
Case Is = 5: oVl.ColumnWidth = 25: Case Is = 6: oVl.ColumnWidth = 25
Case Is = 7: oVl.ColumnWidth = 15
End Select
Next
Else
End If
''' Выгружаем данные на лист
.Range("A1").Resize(iMaxRow, iMaxClmn) = arrTemp '
''' Общее форматирование данных на листе
''' Форматируем шапку таблицы
With .Range(.Cells(1, 1), .Cells(1, 1).Offset(, iMaxClmn - 1))
.HorizontalAlignment = -4108 ' xlCenter
.VerticalAlignment = -4108 ' xlCenter
.Interior.Pattern = 1 ' xlSolid
.Borders.LineStyle = 1 ' xlContinuous
.Font.Bold = True ' шрифт жирный
.WrapText = True ' перенос текста в ячейке
.Interior.ColorIndex = 35
.AutoFilter
End With
.Cells(2, 1).Select: ActiveWindow.FreezePanes = True ''' Закрепить область на второй строке
''' Форматируем общие форматы таблицы
With .Range(.Cells(2, 1), .Cells(iMaxRow, iMaxClmn))
.HorizontalAlignment = -4131 'xlLeft
.VerticalAlignment = -4108
.Borders.LineStyle = 1
.Interior.ColorIndex = -4105
.WrapText = False
.Font.Bold = False
.Rows.AutoFit
.Locked = True
End With
End With
End With
Erase arrTemp
End Sub
Private Function GetCollectionM3UfileText(strFileName) As Variant
' Функция обрабатывает содержимое файлов ASX возвращая массив
' Источник, Категория, Название, Ссылка, Сервер, Обложка, Статус
Dim oVl, iMaxRow As Long
Dim strLine1 As String, strLine2 As String
Dim arr(), arr1(0, 0), tmp, strTemp, strTemp1
Dim i As Long, n As Long
' Загрузка данных из файла в коллекции, считываем весь текс _
Используется UTF8 для коррекктного чтения данных
With CreateObject("ADODB.Stream")
.Charset = "utf-8": .Mode = 3: .Type = 1
.Open
.LoadFromFile strFileName
.Position = 0: .Type = 2
strTemp = .ReadText
oVl = Split(strTemp, vbCrLf)
iMaxRow = UBound(oVl)
.Close
strTemp = vbNullString
End With
strFileName = CreateObject("Scripting.FileSystemObject").GetFileName(strFileName)
' переопределение массива и формирование шапки
ReDim arr(1 To (iMaxRow / 2) + 1, 1 To 7)
i = 1
arr(i, 1) = "Источник": arr(i, 2) = "Категория": arr(i, 3) = "Название"
arr(i, 4) = "Ссылка": arr(i, 5) = "Сервер": arr(i, 6) = "Обложка": arr(i, 7) = "Статус"
For n = 1 To iMaxRow Step 2
If oVl(n) Like "*EXTINF*" Then
i = i + 1
strTemp = Split(oVl(n), ",", -1, 1)
'"Источник"
arr(i, 1) = strFileName
'"Категория"
strTemp(0) = Replace(strTemp(0), "#EXTINF:-1 group-title=", "", 1, -1, 1)
strTemp(0) = Replace(strTemp(0), Chr(34), "", 1, -1, 1)
If strTemp(0) Like "*tvg-logo*" Then
strTemp1 = Split(strTemp(0), "tvg-logo=", -1, 1)
arr(i, 2) = Trim(strTemp1(0))
'"Обложка"
arr(i, 6) = Trim(strTemp1(1))
Else
arr(i, 2) = Trim(strTemp(0))
arr(i, 6) = "-"
End If
'"Название"
If strTemp(1) Like "*===*" Then strTemp(1) = Replace(strTemp(1), "=", "", 1, -1, 1)
arr(i, 3) = strTemp(1)
' "Ссылка"
If oVl(n + 1) Like "*http*" Then arr(i, 4) = oVl(n + 1)
' "Сервер"
strTemp = Split(oVl(n + 1), "/", -1, 1)
arr(i, 5) = strTemp(2)
' "Статус"
arr(i, 7) = "I don't know"
End If
Next n
Erase oVl: oVl = Empty
strFileName = vbNullString
If i > 0 Then GetCollectionM3UfileText = arr Else GetCollectionM3UfileText = arr1
Erase arr
End Function
Private Function GetCollectionASXfileText(objColl As Object) As Variant
' Функция обрабатывает содержимое файлов ASX возвращая массив
Dim strBuf As String, intFreeFile As Long, Lines() As String
Dim strLine1 As String, strLine2 As String
Dim arr(), arr1(0, 0), tmp, temp
Dim i As Long, n As Long
ReDim arr(1 To objColl.Count + 1, 1 To 2): n = 1
For Each tmp In objColl
intFreeFile = FreeFile
Open tmp For Binary As #intFreeFile
strBuf = Space(LOF(intFreeFile))
Get #intFreeFile, , strBuf
Close #intFreeFile
Lines = Split(strBuf, vbCrLf)
strBuf = vbNullString
For i = 0 To UBound(Lines)
If Lines(i) Like "*<TITLE>*" Then
Lines(i) = Replace(Lines(i), "<Entry>", "", 1, -1, vbTextCompare)
Lines(i) = Replace(Lines(i), "<TITLE>", "", 1, -1, vbTextCompare)
Lines(i) = Replace(Lines(i), "</TITLE>", "", 1, -1, vbTextCompare)
Lines(i) = Trim(Lines(i))
strLine1 = Lines(i)
ElseIf Lines(i) Like "*<ref*" Then
Lines(i) = Replace(Lines(i), "<ref HREF=", "", 1, -1, vbTextCompare)
Lines(i) = Replace(Lines(i), "/>", "", 1, -1, vbTextCompare)
Lines(i) = Replace(Lines(i), Chr(34), "", 1, -1, vbTextCompare)
Lines(i) = Trim(Lines(i))
strLine2 = Lines(i)
Else
End If
Next i
If Len(strLine1) > 0 And Len(strLine2) > 0 Then
n = n + 1
arr(n, 1) = strLine1: arr(n, 2) = strLine2
End If
strLine1 = vbNullString: strLine2 = vbNullString
Next
If i > 0 Then GetCollectionASXfileText = arr Else GetCollectionASXfileText = arr1
Erase arr
End Function
Private Function GetCollectionFilesDialog() As Collection
''' Функция диалога выбора файлов FileDialog(msoFileDialogFilePicker)
''' Возвращает коллекцию файлов выбраных пользователем
Dim objColl As New Collection
Dim intSelectFile As Long
Dim strMyDocuments
strMyDocuments = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\"
With Application.FileDialog(3)
.AllowMultiSelect = True
.Title = "Выбрать файлы ASX, m3u8 для обработки"
.Filters.Clear
.Filters.Add "All files", "*.*", 1
.Filters.Add "ASX files", "*.asx", 2
.Filters.Add "m3u8 files", "*.m3u8", 3
.FilterIndex = 3
.InitialFileName = strMyDocuments & "*.*.*.*"
.InitialView = 2
If .Show = 0 Then
Set GetCollectionFilesDialog = objColl
Exit Function
End If
'цикл по коллекции выбранных в диалоге файлов, считываем полный путь к файлу
For intSelectFile = 1 To .SelectedItems.Count
objColl.Add .SelectedItems(intSelectFile)
Next
Set GetCollectionFilesDialog = objColl
End With
End Function
|