Макрос для Microsoft Word по преобразованию файлов с картографическим изображением в формате Postscript

Александр Родионов

Sub PS2CorelDraw()
' Обработка файлов с картографическим изображением Земли
' в формате  Postscript, получаемых с сервера
' http://www.aquarius.geomar.de/omc/make_map.html

Dim i, iH, deltaH, h, isErr As Integer
Dim Message, Title, Default, AName As String
Dim ADocument0, ADocument As String

isErr = False
'Обработка контуров высот

Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "S 1 W^pS 0 A^pS [] 0 B^p% "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    If Selection.Find.Execute = False Then
        ' Нет описания никаких контуров
        GoTo FinishTransformContours
    End If
    'Selection.Find.Execute
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveLeft Unit:=wdWord, Count:=1
    ' контуры высот (абрис) прореживаются и остаются только кратные 1000 метров
        
    ' Set prompt.
    Message = "Введите шаг высоты во входной карте (200 для мелкомасштабных, 500 для крупномасштабных карт)"
    Title = "Шаг высоты во входной карте"
    Default = "500"
    ' Display message, title, and default value.
    deltaH = InputBox(Message, Title, Default)

    ' Set prompt.
    Message = "Введите значение наименьшей высоты контура в выходной карте (1000, 2000, 3000), но не меньше наименьший высоты контура во входной карте (см. текущую строку на экране)"
    Title = "Наименьшая высота контура в выходной карте"
    Default = "1000"
    ' Display message, title, and default value.
    h = InputBox(Message, Title, Default)

    Selection.EndKey Unit:=wdStory, Extend:=wdExtend
    Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
    Selection.Cut
    ADocument0 = ActiveDocument.Name
    Documents.Add
    ADocument = ActiveDocument.Name
    Selection.Paste
    
    For i = 0 To 7 - (h / 1000) Step 1
        iH = h + i * 1000
        Selection.HomeKey Unit:=wdStory
        Selection.Find.ClearFormatting
        With Selection.Find
            ' 1000 - шаг высоты контура в выходной карте
            .Text = "%" & Str(iH) & " contour^p"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        If Selection.Find.Execute = False Then
        ' Нет описания контуров для выходной карты
            isErr = True
            GoTo BeginContourAnnotations
        End If
        Selection.MoveLeft Unit:=wdWord, Count:=1
        Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
        
        iH = h + i * 1000 + deltaH
        Selection.Find.ClearFormatting
        With Selection.Find
            ' шаг высоты контура в выходной карте + шаг высоты во входной карте
            .Text = "%" & Str(iH) & " contour^p"
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        If Selection.Find.Execute = False Then
        ' Нет описания последующего контура во входной карте
            GoTo BeginContourAnnotations2
        End If
        
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
        Selection.Cut
        Documents(ADocument0).Activate
        Selection.Paste
        Documents(ADocument).Activate
        
    Next i
        
BeginContourAnnotations:
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "S [] 0 B^p% Contour annotations"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.MoveLeft Unit:=wdWord, Count:=1
BeginContourAnnotations2:
    Selection.EndKey Unit:=wdStory, Extend:=wdExtend
    Selection.Cut
    Documents(ADocument0).Activate
    If isErr = True Then
       ' Удалить предыдущие три параграфа
        Selection.MoveUp Unit:=wdParagraph, Count:=3, Extend:=wdExtend
        Selection.Delete Unit:=wdCharacter, Count:=1
    End If
    Selection.Paste
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    ' черный цвет контуров высот (абрисы) меняется с "S 1 W^pS 0 A^pS [] 0 B^p% "(RGB: 0, 0, 0)
    ' на светло-серый "S 1 W^pS 0.8 0.8 0.8 c^pS [] 0 B^p% " (RGB: 204, 204, 204)
    
    'With Selection.Find
    '    .Text = "S 1 W^pS 0 A^pS [] 0 B^p% "
    '    .Replacement.Text = "S 1 W^pS 0.8 0.8 0.8 c^pS [] 0 B^p% "
    '    .Forward = True
    '    .Wrap = wdFindContinue
    '    .Format = False
    '    .MatchCase = False
    '    .MatchWholeWord = False
    '    .MatchWildcards = False
    '    .MatchSoundsLike = False
    '    .MatchAllWordForms = False
    'End With
    'Selection.Find.Execute Replace:=wdReplaceAll

    ' Контур для 1000 метров
    With Selection.Find
        .Text = "S 0 A^pS [] 0 B^p% 1000 contour^p"
        .Replacement.Text = "S 0.85 0.85 0.85 C^pS [] 0 B^p% 1000 contour^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    ' Контур для 2000 метров
    With Selection.Find
        .Text = "S 0 A^pS [] 0 B^p% 2000 contour^p"
        .Replacement.Text = "S 0.82 0.82 0.82 C^pS [] 0 B^p% 2000 contour^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    ' Контур для 3000 метров
    With Selection.Find
        .Text = "S 0 A^pS [] 0 B^p% 3000 contour^p"
        .Replacement.Text = "S 0.8 0.8 0.8 C^pS [] 0 B^p% 3000 contour^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    ' Контур для 4000 метров
    With Selection.Find
        .Text = "S 0 A^pS [] 0 B^p% 4000 contour^p"
        .Replacement.Text = "S 0.78 0.78 0.78 C^pS [] 0 B^p% 4000 contour^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    ' Контур для 5000 метров
    With Selection.Find
        .Text = "S 0 A^pS [] 0 B^p% 5000 contour^p"
        .Replacement.Text = "S 0.75 0.75 0.75 C^pS [] 0 B^p% 5000 contour^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    ' Контур для 6000 метров
    With Selection.Find
        .Text = "S 0 A^pS [] 0 B^p% 6000 contour^p"
        .Replacement.Text = "S 0.73 0.73 0.73 C^pS [] 0 B^p% 6000 contour^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

FinishTransformContours:

'
' Преобразование векторной карты в формате Postscript
' в облик по стандартам проектов "Gumilevica"
' Макрос записан 21.11.98 Alexander Rodionov
'
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    ' Суша заливаются вместо грязно-желтого цвета c черной каймой
    ' (абрисом) - "1 0.784 0 c^p" (RGB: 0, 148, 255) на
    ' бледно-серый с серой каймой (абрисом) - "0.98 0.98 0.98 c^p"
    ' (RGB: 242, 242, 242 и RGB: 191, 191, 191)
    With Selection.Find
        .Text = "1 0.784 0 c^p"
        .Replacement.Text = "0.98 0.98 0.98 c^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    ' Водоемы
    ' (a) для водоемов имеющих контактов с границами карты (океаны, моря, озера)
    ' - заливаются вместо синего цвета с черной каймой (абрисом)
    ' "0 0.588 1 c^pS 0 A^p" (RG B: 0, 150,255) цвета на бледно-голубой
    ' с серой каймой (абрисом) "0.7 0.9 1 c^pS 0.75 0.75 0.75 c^p"
    ' (RGB: 179, 230, 255 и RGB: 191, 191, 191);
    ' (b) для водоемов не имеющих контактов с границами карты применяют несколько
    ' измененный шаблон - "0 0.588 1 c^p" на "0.7 0.9 1 c^p"
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "0 0.588 1 c^pS 0 A^p"
        .Replacement.Text = "0.7 0.9 1 c^pS 0.75 0.75 0.75 c^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "0 0.588 1 c^p"
        .Replacement.Text = "0.7 0.9 1 c^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    ' Замена символа градуса "\312)" на правильный "╟"
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\312) "
        .Replacement.Text = "╟) "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    ' Замена размерности расстояния с английского языка "(km)"на русский "(км)"
    With Selection.Find
        .Text = "(km)"
        .Replacement.Text = "(км) "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

End Sub

[ << ] [ Начала Этногенеза ] [ Оглавление ] [ >> ]