Это - персональный сайт

Привет.

Собственно, вот он, макрос. Запускаешь ворд, Сервис-Макросы-Создать и
вставляешь нижеописанное чудо.
Мой 6100 позволяет отображать ммски до 7кб размером. Если у тебя
отображается не вся ммс - поиграйся с SizeLimit.

Как оно работает-
Открываешь в ворде книжку, которую хочешь порезать на ммски. Запускаешь
макрос. После его выполнения в том же каталоге, где лежит твоя книжка
получаешь кучу .mms файлов, которые заливаешь в телефон, как я в форуме
написал.
Хинт. Макрос записывает .mms файлы в тот каталог, куда в последний раз
сохранялся файл. Если не хочешь их искать по всему диску - сохрани книжку
перед запуском макроса. Тогда .mms будут в том каталоге, куда ты сохранил
книжку.

Удачи!



Sub DOC2MMS()
'This is limit size of compiled MMS file will download into phone
memory
'Set value of limit to appropriate size
SizeLimit = 7190
Dim i As Integer
Dim DocCount As Integer
Dim PRange As Range
Dim FileBuf As String
Dim FileSize As Integer
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([.?!])([! .?!])"
.Replacement.Text = "1 2"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
DocCount = 1
Selection.HomeKey Unit:=wdStory
Set OrigPars = ActiveDocument.Paragraphs
ParCount = OrigPars.Count
aNewDoc = NewDoc(1)
FileSize = 6
StartSent = 1
For ParNum = 1 To ParCount
StatusBar = "MMS files generation. Please wait..." + Format(ParNum
/ ParCount, "##%")
SentCount = OrigPars(ParNum).Range.Sentences.Count
StartSent = 1
For EndSent = 1 To SentCount
If OrigPars(ParNum).Range.Characters.Count > 1 Then
Set ParRange = OrigPars(ParNum).Range.Sentences(StartSent)
ParRange.MoveEnd Unit:=wdSentence, Count:=EndSent -
StartSent
FileBuf = ParTextPrepare(ParRange)
Else
FileBuf = Chr(&H20)
End If
If (ParNum = ParCount) And (EndSent = SentCount) Then
FileBufLen = Len(FileBuf + EndSect(1))
Else
FileBufLen = Len(FileBuf + EndSect(DocCount + 1))
End If
DocName = Format(DocCount, "") + ".mms"
If FileSize + FileBufLen > SizeLimit Then
If EndSent > 1 Then
Set ParRange =
OrigPars(ParNum).Range.Sentences(StartSent)
ParRange.MoveEnd Unit:=wdSentence, Count:=EndSent -
StartSent - 1
FileBuf = ParTextPrepare(ParRange)
Put #aNewDoc, , FileBuf
FileSize = FileSize + Len(FileBuf)
End If
FileBuf = EndSect(DocCount + 1)
Put #aNewDoc, , FileBuf
Close #aNewDoc
DocCount = DocCount + 1
EndSent = EndSent - 1
StartSent = EndSent + 1
aNewDoc = NewDoc(DocCount)
FileSize = 6
End If
Next EndSent
If OrigPars(ParNum).Range.Characters.Count > 1 Then
Set ParRange = OrigPars(ParNum).Range.Sentences(StartSent)
ParRange.MoveEnd Unit:=wdSentence, Count:=EndSent - StartSent -
1
FileBuf = ParTextPrepare(ParRange)
Else
FileBuf = Chr(&H20)
End If
Put #aNewDoc, , FileBuf
FileSize = FileSize + Len(FileBuf)
Next ParNum
DocName = Format(DocCount, "") + ".mms"
FileBuf = EndSect(1)
Put #aNewDoc, , FileBuf
Close #aNewDoc
StatusBar = "MMS files generation colmpleted."
End Sub

Private Function ParTextPrepare(ByRef ParRange) As String
ParText = Trim(ParRange.Text)
NewParText = ""
For i = 1 To Len(ParText)
CurChr = Mid(ParText, i, 1)
If (CurChr >= "А") And (CurChr <= "я") Then
Select Case CurChr
Case "А"
CurChr = "A"
Case "Б"
CurChr = Chr(&HD0) + Chr(&H91)
Case "В"
CurChr = "B"
Case "Г"
CurChr = Chr(&HD0) + Chr(&H93)
Case "Д"
CurChr = Chr(&HD0) + Chr(&H94)
Case "Е"
CurChr = "E"
Case "Ё"
CurChr = "E"
Case "Ж"
CurChr = Chr(&HD0) + Chr(&H96)
Case "З"
CurChr = "3"
Case "И"
CurChr = Chr(&HD0) + Chr(&H98)
Case "Й"
CurChr = Chr(&HD0) + Chr(&H99)
Case "К"
CurChr = "K"
Case "Л"
CurChr = Chr(&HD0) + Chr(&H9B)
Case "М"
CurChr = "M"
Case "Н"
CurChr = "H"
Case "О"
CurChr = "O"
Case "П"
CurChr = Chr(&HD0) + Chr(&H9F)
Case "Р"
CurChr = "P"
Case "С"
CurChr = "C"
Case "Т"
CurChr = "T"
Case "У"
CurChr = Chr(&HD0) + Chr(&HA3)
Case "Ф"
CurChr = Chr(&HD0) + Chr(&HA4)
Case "Х"
CurChr = "X"
Case "Ц"
CurChr = Chr(&HD0) + Chr(&HA6)
Case "Ч"
CurChr = Chr(&HD0) + Chr(&HA7)
Case "Ш"
CurChr = Chr(&HD0) + Chr(&HA8)
Case "Щ"
CurChr = Chr(&HD0) + Chr(&HA9)
Case "Ъ"
CurChr = Chr(&HD0) + Chr(&HAA)
Case "Ы"
CurChr = Chr(&HD0) + Chr(&HAB)
Case "Ь"
CurChr = Chr(&HD0) + Chr(&HAC)
Case "Э"
CurChr = Chr(&HD0) + Chr(&HAD)
Case "Ю"
CurChr = Chr(&HD0) + Chr(&HAE)
Case "Я"
CurChr = Chr(&HD0) + Chr(&HAF)
Case "а"
CurChr = "a"
Case "б"
CurChr = Chr(&HD0) + Chr(&HB1)
Case "в"
CurChr = Chr(&HD0) + Chr(&HB2)
Case "г"
CurChr = Chr(&HD0) + Chr(&HB3)
Case "д"
CurChr = Chr(&HD0) + Chr(&HB4)
Case "е"
CurChr = "e"
Case "ё"
CurChr = "e"
Case "ж"
CurChr = Chr(&HD0) + Chr(&HB6)
Case "з"
CurChr = Chr(&HD0) + Chr(&HB7)
Case "и"
CurChr = Chr(&HD0) + Chr(&HB8)
Case "й"
CurChr = Chr(&HD0) + Chr(&HB9)
Case "к"
CurChr = Chr(&HD0) + Chr(&HBA)
Case "л"
CurChr = Chr(&HD0) + Chr(&HBB)
Case "м"
CurChr = Chr(&HD0) + Chr(&HBC)
Case "н"
CurChr = Chr(&HD0) + Chr(&HBD)
Case "о"
CurChr = "o"
Case "п"
CurChr = Chr(&HD0) + Chr(&HBF)
Case "р"
CurChr = "p"
Case "с"
CurChr = "c"
Case "т"
CurChr = Chr(&HD1) + Chr(&H82)
Case "у"
CurChr = "y"
Case "ф"
CurChr = Chr(&HD1) + Chr(&H84)
Case "х"
CurChr = "x"
Case "ц"
CurChr = Chr(&HD1) + Chr(&H86)
Case "ч"
CurChr = Chr(&HD1) + Chr(&H87)
Case "ш"
CurChr = Chr(&HD1) + Chr(&H88)
Case "щ"
CurChr = Chr(&HD1) + Chr(&H89)
Case "ъ"
CurChr = Chr(&HD1) + Chr(&H8A)
Case "ы"
CurChr = Chr(&HD1) + Chr(&H8B)
Case "ь"
CurChr = Chr(&HD1) + Chr(&H8C)
Case "э"
CurChr = Chr(&HD1) + Chr(&H8D)
Case "ю"
CurChr = Chr(&HD1) + Chr(&H8E)
Case "я"
CurChr = Chr(&HD1) + Chr(&H8F)
End Select
ElseIf (Asc(CurChr) > 126) Or (Asc(CurChr) < 32) Then
CurChr = ""
End If
NewParText = NewParText + CurChr
Next i
If Len(NewParText) > 0 Then
NewParText = NewParText + Chr(&HD) + Chr(&HA)
ParTextPrepare = NewParText
Else
ParTextPrepare = Chr(&H20)
End If
End Function

Private Function NewDoc(DocCount As Integer) As Integer
Dim FileBuf As String
DocName = Format(DocCount, "") + ".mms"
On Error Resume Next
Kill DocName
NewDoc = FreeFile
Open DocName For Binary Access Write Lock Write As NewDoc
FileBuf = Chr(&H8C) + Chr(&H80) + Chr(&H98) + Chr(&H5A) + Chr(&H64) +
Chr(&H32) + Chr(&H6A) + Chr(&H34) + Chr(&H41) + Chr(&H47) + Chr(&H67) +
Chr(&H48) + Chr(&H4D) + Chr(&H0) + Chr(&H8D) + Chr(&H90) + Chr(&H89) +
Chr(&H1) + Chr(&H81) + Chr(&H86) + Chr(&H81) + Chr(&H84) + Chr(&HA3) +
Chr(&H1) + Chr(&H4) + Chr(&HFF) + Chr(&H19) + Chr(&H3) + Chr(&H83) +
Chr(&H81) + Chr(&HEA)
Put #NewDoc, , FileBuf
End Function

Private Function EndSect(DocNum As Integer) As String
EndSect = ""
End Function

' (c) Alexey Sokolov. AM_Sokolov@peterstar.ru. 27/01/2002
' (c) MMS optimization. Andrey Vasilevskiy aka Neosphere. neo@mail.ru
27/06/2003