Private Const adReadAll = -1
Private Const adSaveCreateOverWrite = 2
Private Const adTypeBinary = 1
Private Const adTypeText = 2
Private Const adWriteChar = 0
Const SystemFolder = 1, TemporaryFolder = 2
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fso: Set fso = CreateObject("Scripting.FileSystemObject")
Dim tempFolder: tempFolder = fso.GetSpecialFolder(TemporaryFolder)
Dim f, sFile
UTF8toANSI tempFolder & "\1", tempFolder & "\2"
Set f = fso.GetFile(tempFolder & "\2")
if f.Size < 1024 Then
sFile = fso.OpenTextFile(f, ForReading, False, TristateFalse).ReadAll
if InStr(1, sFile, "---------------", 1) = 0 Then
aLines = Split(sFile, vbNewLine)
if Ubound(aLines) < 3 Then
MsgBox sFile, vbOKOnly + vbCritical, "Ошибка"
sOut = " " & "0" & " ! Error torrentcheck !"
else
a3 = Split(aLines(2), " : ")
if Ubound(a3) > 0 Then
a4 = Split(aLines(3), " : ")
a42 = Split(a4(1), " ")
sOut = " " & a42(2) & " " & a3(1)
else
MsgBox sFile, vbOKOnly + vbCritical, "Ошибка"
sOut = " " & "0" & " ! Error torrentcheck !"
end if
end if
Set fo = fso.OpenTextFile(f, ForAppending, True, TristateFalse)
fo.Write vbNewLine
fo.Write "--- ----------- ---------------------------------------------------------------" & vbNewLine
fo.Write sOut
fo.Close
End If
End If
Set fso = nothing
Private Sub UTF8toANSI(ByVal UTF8FName, ByVal ANSIFName)
On Error Resume Next
Dim strText
With CreateObject("ADODB.Stream")
.Open
.Type = adTypeBinary
.LoadFromFile UTF8FName
.Type = adTypeText
.Charset = "utf-8"
strText = .ReadText(adReadAll)
.Position = 0
.SetEOS
.Charset = "windows-1251"
.WriteText strText, adWriteChar
.SaveToFile ANSIFName, adSaveCreateOverWrite
.Close
If Err.Number <> 0 Then
fso.CopyFile tempFolder & "\1", tempFolder & "\2"
End if
End With
End Sub
|
Но вдруг как пример кому-то пригодится: