Ответ на тему "Проблема со шрифтами" от 13 ноября

Коробейников Алексей · 26.11.2004, 11:38

Ответ на тему "Проблема со шрифтами" от 13 ноября 2004г

Дело было так....
В 2002 и 2004 акаде поменялись кодировки форматов шрифтов в МТексте. В 2000 код шрифта имел запись "\f" а в 2002, 2004 "\F"

Вот код VBA на замену во всех активных документах

Код:

[Выделить все]

Option Explicit

Public Function ВыборВсего(ТипФильтра As Variant, ДанныеФильтра As Variant) As AcadSelectionSet
Dim НаборОбъектов As AcadSelectionSet
Dim КолкцияНаборовОбъектов As AcadSelectionSets

Set КолкцияНаборовОбъектов = ThisDrawing.SelectionSets
For Each НаборОбъектов In КолкцияНаборовОбъектов
  If НаборОбъектов.Name = "НАБОР" Then
    НаборОбъектов.Delete
    Exit For
  End If
Next НаборОбъектов
Set НаборОбъектов = ThisDrawing.SelectionSets.Add("НАБОР")
НаборОбъектов.Select acSelectionSetAll, , , ТипФильтра, ДанныеФильтра
Set ВыборВсего = НаборОбъектов

End Function

Public Sub ПреобразованиеКодаМтекста()
Dim НаборДокументов As AcadDocuments
Dim Документ As AcadDocument
Dim МТекст As AcadMText
Dim ТипФильтра(0 To 2) As Integer
Dim ДанныеФильтра(0 To 2) As Variant

ТипФильтра(0) = -4
ТипФильтра(1) = 0
ТипФильтра(2) = -4

ДанныеФильтра(0) = "<OR"
ДанныеФильтра(1) = "MTEXT"
ДанныеФильтра(2) = "OR>"

Set НаборДокументов = ThisDrawing.Application.Documents
For Each Документ In НаборДокументов
    Документ.Activate
    For Each МТекст In ВыборВсего(ТипФильтра, ДанныеФильтра)
        МТекст.textString = Replace(МТекст.textString, "\f", "\F")
    Next МТекст
Next Документ
End Sub

Протестировано на 2004 акаде.
Прошу при любом исходе ответить

Коробейников Алексей · 26.11.2004, 12:44

Похоже небольшая ошибочка :?

Для векторных шрифтов имеем кодитроку {\Fromans.shx|c204;привет}
Для шрифтов имеет кодировку {\fISOCPEUR|b0|i0|c204|p34;привет}

Соответственно меняем код под конкретный случай:
(если прошлый код запустить в файле с TrueType шрифтом то получаем ошибку)

Код:

[Выделить все]

Option Explicit 

Public Function ВыборВсего(ТипФильтра As Variant, ДанныеФильтра As Variant) As AcadSelectionSet 
Dim НаборОбъектов As AcadSelectionSet 
Dim КолкцияНаборовОбъектов As AcadSelectionSets 

Set КолкцияНаборовОбъектов = ThisDrawing.SelectionSets 
For Each НаборОбъектов In КолкцияНаборовОбъектов 
  If НаборОбъектов.Name = "НАБОР" Then 
    НаборОбъектов.Delete 
    Exit For 
  End If 
Next НаборОбъектов 
Set НаборОбъектов = ThisDrawing.SelectionSets.Add("НАБОР") 
НаборОбъектов.Select acSelectionSetAll, , , ТипФильтра, ДанныеФильтра 
Set ВыборВсего = НаборОбъектов 

End Function 

Public Sub ПреобразованиеКодаМтекста() 
Dim НаборДокументов As AcadDocuments 
Dim Документ As AcadDocument 
Dim МТекст As AcadMText 
Dim ТипФильтра(0 To 2) As Integer 
Dim ДанныеФильтра(0 To 2) As Variant 

ТипФильтра(0) = -4 
ТипФильтра(1) = 0 
ТипФильтра(2) = -4 

ДанныеФильтра(0) = "<OR" 
ДанныеФильтра(1) = "MTEXT" 
ДанныеФильтра(2) = "OR>" 

Set НаборДокументов = ThisDrawing.Application.Documents 
For Each Документ In НаборДокументов 
    Документ.Activate 
    For Each МТекст In ВыборВсего(ТипФильтра, ДанныеФильтра) 
        МТекст.textString = Replace(МТекст.textString, "\fRomanS", "\Fromans.shx")
    Next МТекст 
Next Документ 
End Sub

:roll:

26.11.2004, 18:15

И что мне со всем этим делать????? :shock: :shock: :shock: :shock: :shock:

Коробейников Алексей · 29.11.2004, 09:54

1. Копируем код в буфер обмена
2. Открываем Автокад
3. Жмем Альт+F11
4. Открывается Редактор VBA
5. В падающем меню выбираем insert > module
6. Создается новый модуль
7. В него вставляем код из буфера
8. Жмем кнопку сохранить
9. Закрываем редактор VBA
10. Загружаем все чертежи, которые нужно корректировать
11. Жмем Альт+F8
12. Выбираем макрос
13. Жмем RUN

29.11.2004, 10:45

Коробейников Алексей я вам выслал новый файл, возникли проблемы.

Коробейников Алексей · 29.11.2004, 13:52

Вот попробуй, с высланным файлом работает.

Код:

[Выделить все]

Option Explicit 

Public Function ВыборВсего(ТипФильтра As Variant, ДанныеФильтра As Variant) As AcadSelectionSet 
Dim НаборОбъектов As AcadSelectionSet 
Dim КолкцияНаборовОбъектов As AcadSelectionSets 

Set КолкцияНаборовОбъектов = ThisDrawing.SelectionSets 
For Each НаборОбъектов In КолкцияНаборовОбъектов 
  If НаборОбъектов.Name = "НАБОР" Then 
    НаборОбъектов.Delete 
    Exit For 
  End If 
Next НаборОбъектов 
Set НаборОбъектов = ThisDrawing.SelectionSets.Add("НАБОР") 
НаборОбъектов.Select acSelectionSetAll, , , ТипФильтра, ДанныеФильтра 
Set ВыборВсего = НаборОбъектов 
End Function 


Public Sub ПреобразованиеКодаМтекста2()
Dim НаборДокументов As AcadDocuments
Dim Документ As AcadDocument
Dim МТекст As AcadMText
Dim ТипФильтра(0 To 2) As Integer
Dim ДанныеФильтра(0 To 2) As Variant

ТипФильтра(0) = -4
ТипФильтра(1) = 0
ТипФильтра(2) = -4

ДанныеФильтра(0) = "<OR"
ДанныеФильтра(1) = "MTEXT"
ДанныеФильтра(2) = "OR>"

Set НаборДокументов = ThisDrawing.Application.Documents
For Each Документ In НаборДокументов
    Документ.Activate
    Set Документ = ThisDrawing.Application.ActiveDocument
    For Each МТекст In ВыборВсего(ТипФильтра, ДанныеФильтра)
        МТекст.textString = Replace(МТекст.textString, "\fRomans|b0|i0|c204|p2;", "", , , 1)
        МТекст.textString = Replace(МТекст.textString, "\fSymbol|b0|i0|c2|p18;a", "{\fSymbol|b0|i0|c2|p18;a}", , , 1)
        МТекст.textString = Replace(МТекст.textString, "\fSymbol|b0|i0|c2|p18;b", "{\fSymbol|b0|i0|c2|p18;b}", , , 1)
    Next МТекст
Next Документ
End Sub

29.11.2004, 19:38

Посмотрю.

boban · 30.11.2004, 19:05

Просмотрел, есть неполадки, не все тексты стали правильными, выслал файл.
Спасибо за помощь.

Коробейников Алексей · 03.12.2004, 13:26

Пробуй так:

Код:

[Выделить все]

Option Explicit 

Public Function ВыборВсего(ТипФильтра As Variant, ДанныеФильтра As Variant) As AcadSelectionSet 
Dim НаборОбъектов As AcadSelectionSet 
Dim КолкцияНаборовОбъектов As AcadSelectionSets 

Set КолкцияНаборовОбъектов = ThisDrawing.SelectionSets 
For Each НаборОбъектов In КолкцияНаборовОбъектов 
  If НаборОбъектов.Name = "НАБОР" Then 
    НаборОбъектов.Delete 
    Exit For 
  End If 
Next НаборОбъектов 
Set НаборОбъектов = ThisDrawing.SelectionSets.Add("НАБОР") 
НаборОбъектов.Select acSelectionSetAll, , , ТипФильтра, ДанныеФильтра 
Set ВыборВсего = НаборОбъектов 
End Function 

Public Sub ПреобразованиеКодаМтекста2()
Dim НаборДокументов As AcadDocuments
Dim Документ As AcadDocument
Dim позицияF As Long
Dim позицияТочСЗап As Long
Dim Строка As String
Dim ОбрезаннаяСтрока As String
Dim МТекст As AcadMText
Dim ТипФильтра(0 To 2) As Integer
Dim ДанныеФильтра(0 To 2) As Variant
Dim Точка(0 To 2) As Double

ТипФильтра(0) = -4
ТипФильтра(1) = 0
ТипФильтра(2) = -4

ДанныеФильтра(0) = "<OR"
ДанныеФильтра(1) = "MTEXT"
ДанныеФильтра(2) = "OR>"

Set НаборДокументов = ThisDrawing.Application.Documents
For Each Документ In НаборДокументов
    Документ.Activate
    Set Документ = ThisDrawing.Application.ActiveDocument
    For Each МТекст In ВыборВсего(ТипФильтра, ДанныеФильтра)
        Строка = МТекст.textString
начало:
        позицияF = InStr(1, Строка, "\f", 1)
        If позицияF = 0 Then GoTo Следующий
        ОбрезаннаяСтрока = Right(Строка, Len(Строка) - позицияF + 1)
        позицияТочСЗап = InStr(1, ОбрезаннаяСтрока, ";", 1)
        ОбрезаннаяСтрока = Right(ОбрезаннаяСтрока, Len(ОбрезаннаяСтрока) - позицияТочСЗап)
        Строка = Left(Строка, позицияF - 1) & ОбрезаннаяСтрока
        GoTo начало
Следующий:
        Строка = Replace(Строка, "{", "", , , 1)
        Строка = Replace(Строка, "}", "", , , 1)
        If Left(ThisDrawing.Application.Version, 2) = "15" Then МТекст.textString = Строка
        If Left(ThisDrawing.Application.Version, 2) = "16" Then МТекст.textString = "{\Fromans.shx|c204;" & Строка & "}"
    Next МТекст
Next Документ
End Sub

boban · 03.12.2004, 18:15

У меня такой еще вопрос в чем проблема кроется??? И почему разработчики Акада не исправят эту проблему??
И еще проблема с размерным текстом, если я его изменяю, добавляю другой текст, можно ли это исправить, а то я посмотрел эта прога не испарвляет размеры.

boban · 05.12.2004, 21:49

Спасибо за помощь!!!!

Пока все работает, проблем не заметил.
Можно ли сделать так чтобы при открытие чертежа автоматически происходило обновление. И еще чтобы новый текст при написание сразу создавался нормальный, а то потом приходится его исправлять????