purebasic.info

PureBasic forum
Текущее время: Ср апр 25, 2018 7:39 am

Часовой пояс: UTC + 3 часа




Начать новую тему Ответить на тему  [ 1 сообщение ] 
Автор Сообщение
 Заголовок сообщения: Создание MHT-архива
СообщениеДобавлено: Пт май 04, 2012 3:07 pm 
Не в сети
профессор
Аватар пользователя

Зарегистрирован: Пн апр 27, 2009 5:18 pm
Сообщений: 387
Откуда: Череповец, Вологодская область
Благодарил (а): 0 раз.
Поблагодарили: 0 раз.
Пункты репутации: 0
Как-то давным давно надо было портировать с PHP возможность создания MHT-архивов из веб-страниц. Данный код не стал усложнять. Он поддерживает создание архива из одной страницы с изображениями.
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
 
;
; ====================
; MHT Library Maker PB
; http://www.bacolab.ru/
; ====================
;
 
Procedure.s GetMIMEType(FilePath$)
        Select GetExtensionPart(FilePath$)
                Case "htm"
                        ProcedureReturn "text/html"
                Case "html"
                        ProcedureReturn "text/html"
                Case "txt"
                        ProcedureReturn "text/plain"
                Case "cgi"
                        ProcedureReturn "text/plain"
                Case "php"
                        ProcedureReturn "text/plain"
                Case "css"
                        ProcedureReturn "text/css"
                Case "jpg"
                        ProcedureReturn "image/jpeg"
                Case "jpeg"
                        ProcedureReturn "image/jpeg"
                Case "jpe"
                        ProcedureReturn "image/jpeg"
                Case "gif"
                        ProcedureReturn "image/gif"
                Case "png"
                        ProcedureReturn "image/png"
                Default
                        ProcedureReturn "application/octet-stream"
        EndSelect
EndProcedure
 
Procedure.s ChunkFileWithBase64(*Buffer)
        If *Buffer
                *MemoryBuffer = AllocateMemory(MemorySize(*Buffer) * 1.4)
                Base64Encoder(*Buffer, MemorySize(*Buffer), *MemoryBuffer, MemorySize(*Buffer) * 1.4)
                Text$ = PeekS(*MemoryBuffer)
                FreeMemory(*MemoryBuffer)
                FreeMemory(*Buffer)
                For i = 1 To Len(Text$) Step 76
                        NewText$ + Mid(Text$, i, 76) + #CRLF$
                Next
                ProcedureReturn NewText$
        EndIf
EndProcedure
 
Procedure CreateWebArchive(FileName$, Directory$, FirstFile$)
       
        Stamp$ = Str(Date())
        Stamp$ = UCase(MD5Fingerprint(@Stamp$, Len(Stamp$))) + "_MULTIPART_MIXED"
       
        Content$ = "From: PureMHTLib <baco@nm.ru>" + #CRLF$
        Content$ + "Subject: PureMHTLib" + #CRLF$
        Content$ + "MIME-Version: 1.0" + #CRLF$
        Content$ + "Content-Type: multipart/related;" + #CRLF$
        Content$ + Chr(9) + "boundary=" + Chr(34) + "--" + Stamp$ + Chr(34) + ";" + #CRLF$
        Content$ + Chr(9) + "type=" + Chr(34) + GetMIMEType(Directory$ + FirstFile$) + Chr(34) + #CRLF$
        Content$ + "X-MimeOLE: Produced By MHT Library Maker PB" + #CRLF$ + #CRLF$
        Content$ + "This is a multi-part message in MIME format." + #CRLF$ + #CRLF$
       
        Directory = ExamineDirectory(#PB_Any, Directory$, "*.*")
        If Directory
                While NextDirectoryEntry(Directory)
                        If DirectoryEntryType(Directory) = #PB_DirectoryEntry_File
                                File = OpenFile(#PB_Any, Directory$ + DirectoryEntryName(Directory))
                                If File
                                        *FileCont = AllocateMemory(Lof(File))
                                        ReadData(File, *FileCont, Lof(File))
                                        CloseFile(File)
                                EndIf
                                Content$ + "----" + Stamp$ + #CRLF$
                                Content$ + "Content-Type: " + GetMIMEType(Directory$ + DirectoryEntryName(Directory)) + #CRLF$
                                Content$ + "Content-Transfer-Encoding: base64" + #CRLF$
                                Content$ + "Content-Location: http://mhtfile/" + DirectoryEntryName(Directory) + #CRLF$ + #CRLF$
                                Content$ + ChunkFileWithBase64(*FileCont) + #CRLF$
                        EndIf
                Wend
                FinishDirectory(Directory)
        EndIf
       
        Content$ + "----" + Stamp$ + "--"
       
        File = OpenFile(#PB_Any, FileName$)
        If File
                WriteString(File, Content$)
                CloseFile(File)
        EndIf
       
EndProcedure
 
; CreateWebArchive("D:\web.mht", "D:\new\", "index.html")



Вернуться наверх
 Профиль  
 
Показать сообщения за:  Сортировать по:  
Начать новую тему Ответить на тему  [ 1 сообщение ] 

Часовой пояс: UTC + 3 часа


Кто сейчас на форуме

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 2


Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
cron
Создано на основе phpBB® Forum Software © phpBB Group (блог о phpBB)
Сборка создана CMSart Studio
Русская поддержка phpBB