Я пробовал экспериментировать с использованием редактора MathType или Microsoft Equation 3 и понял что можно конвертировать выражения написанные на языке "LaTeX" в формулы вида MathType.
Мне формулы MathType больше нравятся так как при копировании их в Excel для пояснения расчётов они там выглядят очень ровными, гладкими и красивыми а формулы Word2007 просто квадратные, "бездушные" и некрасивые.
Вот некоторые примеры формул написанные на языке LaTex:
- Код: Выделить всё
\sqrt{x+\sqrt{y}}
\sqrt[mn]{x+y} \quad \sqrt[3]{2}
\surd[x+y]
\begin{array}{l}
a\bmod n=b \\
a\equiv b\pmod n \\
a\equiv b\mod n \\
a\equiv b\pod n
\end{array}
\frac{a+b}{x+\log\frac{Y}{Z}}
a_k = \begin{cases}
k & \text{for $k \le n/2$} \\
n & \text{for $k=n/2$} \\
k-1 & \text{otherwise}
\end{cases}
Вот здесь интересная табличка с операторами языка LaTex: elevatorlady.ca/data/tex-refcard-letter.pdf
А вот здесь краткое руководство как использовать этот язык: ftp ams.org/pub/tex/doc/amsmath/short-math-guide.pdf
Чтобы активизировать методы MathType на VBA надо установить MathType и включить ссылки на объекты MathTypeCommands и MTCommandsMain в Reference VBA.
Загрузить демо версию MathType которую я сейчас использую можно отсюда: dessci.com/en/products/MathType/trial.asp
Следующий макрос которые работают из VBA для Word создают несколько формул которые мне нужны в отчёте:
- Код: Выделить всё
Public Sub FormulaInWord(strText As String)
Dim objRange As InlineShape
On Error Resume Next
'Перемещаемся в конец документа чтобы ЛинеШейпа выделилась новая
Selection.EndKey Unit:=wdStory
'Этот метод путём ошибок создаёт новую линешейпу в которую мы добавим свою формулу
MTCommandsMain.toggleInlineTeXEqn Selection.Range
'Выделение новой линешейпы
Set objRange = ActiveDocument.InlineShapes(ActiveDocument.InlineShapes.Count)
' Set objRange = ActiveDocument.InlineShapes.AddOLEObject("Equation.DSMT4")
'Добавление формулы в новую линешейпу
MTCommandsMain.MTTeXToggle.setMTTeXData objRange, strText
''Нажимаем на кнопку "ОК"
' SendKeys "{Enter}", True
End Sub
Sub Макрос8()
FormulaInWord "h_0=h-a_зс"
Selection.Range.InsertParagraphAfter
FormulaInWord "\omega=0,85-0,008R_b"
Selection.Range.InsertParagraphAfter
FormulaInWord "\xi_y=\frac{\omega}{1+\frac{R_s}{500}\left(1-\frac{\omega}{1,1}\right)}"
Selection.Range.InsertParagraphAfter
FormulaInWord "\alpha_m=\frac{M}{R_b b h_0^2}"
Selection.Range.InsertParagraphAfter
FormulaInWord "\xi=1-\sqrt{1-2\alpha_m}"
Selection.Range.InsertParagraphAfter
FormulaInWord "\zeta=1-0,5\xi"
Selection.Range.InsertParagraphAfter
FormulaInWord "A_s=\frac{M}{R_b \zeta h_0}"
Selection.Range.InsertParagraphAfter
End Sub
В следующем коде я пытаюсь создать отчёт в Word из Excel
- Код: Выделить всё
Private Sub CommandButton1_ОтчётПоДиамАрм_Click()
'Функция создаёт отчёт по вычислению требуемого диаметра арматуры
Dim appWD As Object, objDoc As Word.Document, vЛистДанных As Variant, rngНачЯч As Range
Dim strТекст As String, strСтрока As String, strСимвол As String, dblЧисло1 As Double, dblЧисло2 As Double
Dim colСтроки As Collection, strВывод As String, rngЯчейка As Range
On Error GoTo ОбработкаОшибок
' Set vЛистДанных = Sheets("Расчёт фундамента")
'Получим доступ к файлу Word
On Error Resume Next
Set appWD = GetObject(, "Word.Application")
If appWD Is Nothing Then
Set appWD = CreateObject("Word.Application")
appWD.Visible = True
Set objDoc = appWD.Documents.Add
objDoc.Range.WholeStory
objDoc.Selection.Delete
Else
Set objDoc = appWD.ActiveDocument
End If
On Error GoTo ОбработкаОшибок
'Заполним ячейки нового отчёта
Set rngНачЯч = Range("НачЯчВычТребДиам1Арм")
'Выведем название расчёта
strТекст = "Вычисление диаметра требуемой арматуры"
ТекстВWord objDoc, strТекст, 14, True, , , True
objDoc.Range.InsertParagraphAfter
'Выведем величины изгибающих моментов
dblЧисло1 = Round(CDbl(rngНачЯч.Offset(2, 1)), 3)
dblЧисло2 = Round(CDbl(rngНачЯч.Offset(3, 1)), 3)
' appWD.FormulaInWord "\xi_y=\frac{\omega}{1+\frac{R_s}{500}\left(1-\frac{\omega}{1,1}\right)}"
appWD.FormulaInWord appWD, "\xi_y=\frac{\omega}{1+\frac{R_s}{500}\left(1-\frac{\omega}{1,1}\right)}"
strТекст = CStr(dblЧисло1) & " тс*м =" & dblЧисло2 & " МН*м - изгибающий момент"
ТекстВWord objDoc, strТекст, 12, True, True, True
objDoc.Range.InsertParagraphAfter
objDoc.Range.InsertParagraphAfter
strТекст = "Расчёт выполнил:"
ТекстВWord objDoc, strТекст
strТекст = "Расчёт проверил:"
ТекстВWord objDoc, strТекст
strТекст = "Дата: " & Format(Time, "hh:mm") & ", " & Date
ТекстВWord objDoc, strТекст
objDoc.Range.InsertParagraphAfter
'Выведем сообщение о выполненной работе
MsgBox "Отчёт по расчёту фундамента составлен", vbInformation
Application.WindowState = xlMinimized
objDoc.Application.WindowState = wdWindowStateMaximize
Exit Sub
ОбработкаОшибок:
MsgBox "При создании отчёта в Word произошла ОШИБКА!" & vbLf & vbLf & _
"Номер ошибки = " & Err.Number & "," & vbLf & vbLf & _
"Описание ошибки: """ & Err.Description & """.", vbInformation
Resume Next
End Sub
Public Function ТекстВWord(objDoc As Word.Document, strТекст As String, Optional dblРазмер As Double = 12, Optional blnЖирный As Boolean = False, _
Optional blnКурсив As Boolean = False, Optional blnПодчёркивание As Boolean = False, Optional blnВыравнПоЦентру As Boolean = False)
Dim lngДлина As Long, objRange As Word.Range
On Error GoTo ОбработкаОшибок
objDoc.Range.InsertAfter strТекст
'Зададим требуемую высоту текста
lngДлина = Len(strТекст)
Set objRange = objDoc.Range(Start:=objDoc.Range.End - lngДлина - 1, End:=objDoc.Range.End - 1)
objRange.Font.Size = dblРазмер
objRange.Font.Name = "Times New Roman"
If blnЖирный Then
objRange.Font.Bold = wdToggle
Else
objRange.Font.Bold = wdNone
End If
If blnКурсив Then
objRange.Font.Italic = wdToggle
Else
objRange.Font.Italic = wdNone
End If
If blnПодчёркивание Then
objRange.Font.Underline = wdUnderlineSingle
Else
objRange.Font.Underline = wdNone
End If
If blnВыравнПоЦентру Then
objRange.Paragraphs.Alignment = wdAlignParagraphCenter
Else
objRange.Paragraphs.Alignment = wdAlignParagraphLeft
End If
objRange.InsertParagraphAfter
Exit Function
ОбработкаОшибок:
MsgBox "При выводе текста в Word произошла ОШИБКА!" & vbLf & vbLf & _
"Номер ошибки = " & Err.Number & "," & vbLf & vbLf & _
"Описание ошибки: """ & Err.Description & """.", vbInformation
Resume Next
End Function
Public Sub FormulaInWord(appWD As Object, strText As String)
Dim objRange As InlineShape, objMathType As Object
On Error Resume Next
'Перемещаемся в конец документа чтобы ЛинеШейпа выделилась новая
appWD.Selection.EndKey Unit:=wdStory
'Этот метод путём ошибок создаёт новую линешейпу в которую мы добавим свою формулу
Set objMathType = appWD.VBE.vbprojects("MTCommandsMain")
appWD.MTCommandsMain.toggleInlineTeXEqn appWD.Selection.Range
'Выделение новой линешейпы
Set objRange = appWD.ActiveDocument.InlineShapes.Create
'Добавление формулы в новую линешейпу
objMathType.MTTeXToggle.setMTTeXData objRange, strText
'Нажимаем на кнопку "ОК"
appWD.SendKeys "{Enter}", True
End Sub
Скажите почему у меня это не получается!
