Advertising
Paste Description for olecom
msword is inserting phpbb post tags for you
- olecom
- Sunday, September 5th, 2010 at 5:41:59pm MDT
- ==
- == File of "Microsoft Word Objects" aka ThisDocument: Форум_GallopeRU_v001.cls ==
- ==
- VERSION 1.0 CLASS
- BEGIN
- MultiUse = -1 'True
- END
- Attribute VB_Name = "Форум_GallopeRU_v001"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = True
- ' _v001 -- 1) поддержка текстованных urlов; они синие и подчёркиваются (порядок тэгов для форума важен)
- ' 2) убрал маленький шрифт для форумтэгов (нафига, когда они undoца)
- ' подключаемся к событиям окон, для ловли выделения (больше ничего Word не может предложить)
- Dim События As New Класс_Событий
- Sub Document_Open()
- Set События.прога = Word.Application
- End Sub
- ==
- == File of "Class Modules": Класс_Событий.cls ==
- ==
- VERSION 1.0 CLASS
- BEGIN
- MultiUse = -1 'True
- END
- Attribute VB_Name = "Класс_Событий"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = False
- Attribute VB_Exposed = False
- Public WithEvents прога As Word.Application
- Attribute прога.VB_VarHelpID = -1
- Sub прога_WindowSelectionChange(ByVal Sel As Selection)
- Dim i, j, s, d, возврат, имя
- If Len(Sel.Range.Document.Content.Text) = Len(Sel.Text) Then
- параментры_поста.Show
- If параментры_поста.Tag <> "АГА" Then
- Exit Sub
- End If
- If Right(параментры_поста.адрес, 1) <> "/" Then
- параментры_поста.адрес = параментры_поста.адрес & "/"
- End If
- ActiveDocument.Save
- имя = ActiveDocument.Path + "\" + ActiveDocument.Name
- d = ActiveDocument.Path + "\" + "Картинки-" & ActiveDocument.Name
- Set fs = CreateObject("Scripting.FileSystemObject")
- On Error Resume Next ' вЫрубаем ошибки
- fs.DeleteFolder ActiveDocument.Path + "\" + d + ".files"
- On Error GoTo 0 ' врубаем ошибки
- ActiveDocument.SaveAs FileName:=d + ".htm", FileFormat:=wdFormatFilteredHTML, AddToRecentFiles:=False
- возврат = 0
- ' жирный
- Sel.HomeKey Unit:=wdStory
- With Sel.Find
- .ClearFormatting
- .Font.Bold = True
- Do While .Execute(FindText:="", Forward:=True, Format:=True, Wrap:=wdFindStop) = True
- i = Len(Sel.Text)
- With .Parent
- .InsertBefore "[b]"
- .InsertAfter "[/b]"
- End With
- Selection.MoveRight Unit:=wdCharacter, Count:=1
- возврат = возврат + 2
- Loop
- End With
- ' курсив
- Sel.HomeKey Unit:=wdStory
- With Sel.Find
- .ClearFormatting
- .Font.Italic = True
- Do While .Execute(FindText:="", Forward:=True, Format:=True, Wrap:=wdFindStop) = True
- i = Len(Sel.Text)
- With .Parent
- .InsertBefore "[i]"
- .InsertAfter "[/i]"
- End With
- Selection.MoveRight Unit:=wdCharacter, Count:=1
- возврат = возврат + 2
- Loop
- End With
- ' подчёркнутый
- Sel.HomeKey Unit:=wdStory
- With Sel.Find
- .ClearFormatting
- .Font.Underline = wdUnderlineSingle
- Do While .Execute(FindText:="", Forward:=True, Format:=True, Wrap:=wdFindStop) = True
- i = Len(Sel.Text)
- With .Parent
- .InsertBefore "[u]"
- .InsertAfter "[/u]"
- End With
- Selection.MoveRight Unit:=wdCharacter, Count:=1
- возврат = возврат + 2
- Loop
- End With
- ' картинки
- i = 0
- j = Dir(d + ".files\image*.*")
- For Each картинка In ActiveDocument.InlineShapes
- Dim f
- s = Right(j, 4)
- If картинка.AlternativeText = "" Then
- ' формируем туповатое имя и расширение
- f = параментры_поста.имя + VBA.CStr(i) + s
- s = vbCrLf + "[img]" + параментры_поста.адрес + f + "[/img]"
- Else
- ' альтернативный текст -- это имя файла картинки, и оно должно быть похоже на имя для Винды
- f = VBA.Replace(VBA.Replace(картинка.AlternativeText, " ", "_"), ":", "")
- f = VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(f, "\", ""), "/", ""), "?", ""), "*", "")
- f = VBA.Replace(VBA.Replace(VBA.Replace(VBA.Replace(f, "<", ""), ">", ""), "|", ""), Chr(34), "")
- f = параментры_поста.имя + f + s
- ' к префиксу добавляем имя и расширение
- s = vbCrLf + "[img]" + параментры_поста.адрес + f + "[/img]"
- End If
- On Error Resume Next ' вЫрубаем ошибки
- fs.DeleteFile d + ".files\" + f ' убираем, возможно уже имеющийся файл
- fs.MoveFile d + ".files\" + j, d + ".files\" + f ' переименовываем
- On Error GoTo 0 ' врубаем ошибки
- картинка.Range.InsertAfter s
- j = Dir
- i = i + 1
- возврат = возврат + 1
- Next
- ' линки
- For Each h In ActiveDocument.Hyperlinks
- With h.Range
- .InsertBefore "[url=" + h.Address + "#" + h.SubAddress + "][color=#0000FF]"
- .InsertAfter "[/color][/url]"
- End With
- возврат = возврат + 2
- Next
- ' завершение работы
- Selection.WholeStory
- Selection.Copy
- ActiveDocument.Undo возврат
- ActiveDocument.SaveAs имя, wdFormatDocument
- Sel.EndKey Unit:=wdStory
- ActiveWindow.View.Type = wdNormalView
- fs.DeleteFile d + ".htm"
- ChDir ActiveDocument.Path
- End If
- End Sub
- ==
- == File of "Forms": параментры_поста.frm ==
- ==
- VERSION 5.00
- Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} параментры_поста
- Caption = "Преобразование текста для форума Galloper.ru (движок phpBB)"
- ClientHeight = 3300
- ClientLeft = 45
- ClientTop = 330
- ClientWidth = 11055
- OleObjectBlob = "параментры_поста.frx":0000
- StartUpPosition = 1 'CenterOwner
- Tag = "0"
- End
- Attribute VB_Name = "параментры_поста"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- Sub CommandButton1_Click()
- Tag = "АГА"
- Hide
- End Sub
- Sub CommandButton2_Click()
- Tag = ""
- Hide
- End Sub
advertising
Update the Post
Either update this post and resubmit it with changes, or make a new post.
You may also comment on this post.
Please note that information posted here will expire by default in one month. If you do not want it to expire, please set the expiry time above. If it is set to expire, web search engines will not be allowed to index it prior to it expiring. Items that are not marked to expire will be indexable by search engines. Be careful with your passwords. All illegal activities will be reported and any information will be handed over to the authorities, so be good.
