Добрый день. Есть макрос в exel , который по размерам из таблицы рисует прямоугольники в Corel . Каждый раз создавая новый документ. Можно ли сделать так , что бы документ очищался и в нем уже рисовались прямоугольники ?
Код:
Option Explicit
Dim MyAddress As String
Dim SelRows As Integer
Dim SelCols As Integer
Dim strTemp
Dim i, j, H As Long
Dim objCorel As New CorelDRAW.Application
Dim CrlDoc As New CorelDRAW.Document
Dim CurrX, buff_X As Long
Dim CurrY As Long
Const PageWidth = 8000
Const PageHeight = 6000
Sub MyMacro1()
'Читаем выделение в массив...
MyAddress = Selection.Address(ReferenceStyle:=xlA1, ColumnAbsolute:=False, RowAbsolute:=False)
Debug.Print MyAddress
SelRows = Selection.Rows.Count
Debug.Print SelRows
SelCols = Selection.Columns.Count
Debug.Print SelCols
ReDim mRect(1 To SelRows)
For i = 1 To SelRows
mRect(i).Y = CSng(Selection.Cells(i, 1).Text)
mRect(i).X = CSng(Selection.Cells(i, 2).Text)
If SelCols > 2 Then
mRect(i).Count = CSng(Selection.Cells(i, 3).Text)
Else
mRect(i).Count = 1
End If
Next i
'Работа с коралом
Set objCorel = New CorelDRAW.Application
CurrX = 0
H = 0
CurrY = PageHeight
objCorel.Visible = True
Set CrlDoc = objCorel.CreateDocument
objCorel.ActiveDocument.Unit = cdrMillimeter
With objCorel.ActiveDocument.ActivePage
.SetSize PageWidth, PageHeight
End With
For i = 1 To SelRows
H = H + mRect(i).Y + 80
If (PageHeight - H) <= (mRect(i).Y) Then
CurrX = CurrX + 500
CurrY = PageHeight
H = 0
End If
For j = 1 To mRect(i).Count
If j = 1 Then
buff_X = CurrX
End If
Call objCorel.ActiveLayer.CreateRectangle(CurrX, CurrY, CurrX + mRect(i).X, CurrY - (mRect(i).Y))
CurrX = CurrX + mRect(i).X + 80
If j = mRect(i).Count Then
CurrX = buff_X
End If
Next j
CurrY = CurrY - mRect(i).Y - 80
Next i
End Sub
