Макрос для 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
|
|
11/12/24 - 03:50
|
[ << ] [ Начала Этногенеза ] [ Оглавление ] [ >> ]
| |
|