olecom

==
== 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