Экспорт в Word

Option Explicit
Public Sub PointsToTable(ByVal cPoints As Variant)
' by fixo () 2007 * all rights removed
' make sure you set reference to Microsoft Word Object Library and also
' set options in Tools->Options->General tab->Break on Unhandled Errors
Dim wrd As Object
Dim wdoc As Object
Dim wtbl As Object
Dim rng As Object
Dim i As Integer
Dim j As Integer
Dim ed As Integer
Dim fname As String
Dim pts As Long
Dim its As Long
pts = UBound(cPoints, 1)
its = UBound(cPoints, 2)
fname = ThisDrawing.Path & "\" & "Points.doc" '<--change the full path here
Set wrd = CreateObject("Word.Application")
wrd.Visible = True
wrd.Activate
Set wdoc = wrd.Documents.Open(fname)
wdoc.Activate
Set wdoc = wrd.ActiveDocument
wrd.ScreenUpdating = False
    With wdoc
        .Activate
        .ActiveWindow.Visible = True
        .Select
        With .PageSetup
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.748)
        .BottomMargin = InchesToPoints(1.2)
        .RightMargin = InchesToPoints(0.54)
        End With
    End With
Set rng = wdoc.Range(Start:=0, End:=0)
        With rng.Paragraphs(1).Range
        .Font.Size = 9
        .Font.Bold = True
        .Font.Name = "Tahoma"
        .Font.color = wdColorBlue
        End With
rng.InsertBefore Text:="Point Coordinates:" & vbCr & vbCr
Set rng = wdoc.Range
ed = rng.End - 1
Set wtbl = wdoc.Tables.Add(Range:=wdoc.Range(Start:=ed, End:=ed), NumRows:=pts + 1, NumColumns:=its + 1)
For i = 1 To wtbl.Rows.Count
For j = 1 To wtbl.Columns.Count
wtbl.Cell(i, j).Range.ParagraphFormat.Alignment = WdParagraphAlignment.wdAlignParagraphLeft
wtbl.Columns(j).Cells(i).Range.Text = CStr(cPoints(i - 1, j - 1))
Next
Next
Set rng = Nothing
wrd.ScreenUpdating = True
wrd.Selection.Collapse
wdoc.Save
wdoc.Close
wrd.Quit
Set wdoc = Nothing
Set wrd = Nothing
End Sub
Sub sGetPoint()
 ' written by mig8 (Greg)
MsgBox "Wait, please..."
Dim pts(0 To 1000, 0 To 2) As Double
Dim vPoint As Variant
Dim i As Integer
Dim k As Integer
vPoint = ThisDrawing.Utility.GetPoint(, vbCr & "Pick a first point: ")
For i = 0 To UBound(vPoint)
pts(k, i) = CDbl(vPoint(i))
Next
k = k + 1
On Error Resume Next
Do
vPoint = ThisDrawing.Utility.GetPoint(vPoint, vbCr & "Pick a next point (or press Enter to Exit)")
For i = 0 To UBound(vPoint)
pts(k, i) = CDbl(vPoint(i))
Next
k = k + 1
Loop While Err = 0
Dim npts() As Double
ReDim npts(k - 1, 2) As Double
For i = 0 To UBound(npts, 1)
For k = 0 To 2
npts(i, k) = pts(i, k)
Next
Next
Call PointsToTable(npts)
MsgBox "Done"
End Sub

Option Explicit
Sub Word_dok()
Dim Word_app As Object
Dim Word_book As Object
Set Word_app = CreateObject("Word.Application")
Word_app.Visible = True
Word_app.Activate
With Word_app
.Documents.Add
With Word_app
.Selection.TypeText Text:="Учи матчасть"
End With
End With
Set Word_book = Word_app.ActiveDocument
Word_book.SaveAs ThisDrawing.Path & "\Daria.doc"
Word_book.Close
Word_app.Quit
Set Word_book = Nothing
Set Word_app = Nothing
End Sub