[CDR X5-X8] Очень тормозит при создании 10000 прямоугольников

[Rusta]

Задача такая: читаю текстовый файл с координатами, и создаю квадратики в заданном месте с определенным углом поворота.
При количестве квадратиков превышающем 1000 шт, корел уходит в глубокую задумчивость минут на пять, без всякой реакции, потом просыпается с результатом.
При количестве 10000 шт он зависает на 30 минут.
Мне же необходимо от 10000 до 50000 квадратиков импортировать.
Я понимаю что процедура ActiveLayer.CreateRectangle и потом Rotate жрет много ресурсов, так как содержит в себе много операция.
Вопрос возможно ли как-то создавать эти квадратики в памяти, а потом выводить в Layer?
Или запретить на время импорта операции отрисовки?
Потому как если полученный файл записать в CDR и потом повторно открыть, тратится менее 1 сек.

 

[Rusta]

Кусок Кода:

Set fs = CreateObject("Scripting.FileSystemObject")
Set fileout = fs.OpenTextFile(File, 1)

While Not fileout.AtEndOfStream
sx = 1
Data = fileout.ReadLine
sx = InStr(sx, Data, " ", vbTextCompare)
X = CSng(Left(Data, sx))
sy = InStr(sx + 1, Data, " ", vbTextCompare)
Y = CSng(Mid(Data, sx + 1, sy - sx))
sa = InStr(sy + 1, Data, " ", vbTextCompare)
Angle = CSng(Mid(Data, sy + 1, sa - sy))
clr = CInt(Right(Data, Len(Data) - sa))

!!! Set sh = Panno.CreateRectangle2(X , -Y , 10, 10)
!!! sh.Rotate (-Angle)
!!! sh.Fill.UniformColor = pallete.Colors(clr)

Wend
fileout.Close

 

[_MBK_]

Самое простое решение - создавайте файл какого нибудь простого текстового формата (скажем EPS) а потом скопом импортируйте его в корел

 

[_MBK_]

Основная проблема, на самом деле, не в том, что

процедура ActiveLayer.CreateRectangle и потом Rotate жрет много ресурсов, так как содержит в себе много операция.

Дело в том, что интерпретатор VBA внутри оптимизирован из рук вон плохо, а еще хуже оптимизирована его интеграция в CDR
В итоге, мы имеем большую дефрагментацию ресурсов в процессе работы, из-за которой скорость создания каждого последующего объекта падает в геометрической прогрессии и сделать с этим что-то чрезвычайно сложно. Корел - это все таки не автокад и его автоматизация не была изначально заточена под работу с таким большим количеством объектов.
Когда же вы импортируете файл с большим количеством объектов, то фильтр импорта сразу планирует ресурсы под это, в итоге получается быстрее. Но 50000 прямоугольников будет хоть и не полчаса,но все равно достаточно ощутимо долго импортироваться, а главное,прорисовываться, морально готовьтесь к этому.

 

[lev]

Добавьте в начало кода
Optimization = True
в конец
Optimization = False
ActiveWindow.Refresh
Refresh
сравните время.
Если не сильно помогло, будем думать дальше

 

[_MBK_]

Если не сильно помогло, будем думать дальше

А по мне, так при таком количестве объектов половинчатые решения не годятся, нужно сразу прибегать к радикальным

 

[izrukvruki]

Если создавать 50 файлов, в каждом по 1000 прямоугольников. а потом эти 50 файлов импортировать в один файл?
Так может хоть зависаний не будет...

На каком то этапе нельзяли как-то скомбинировать объекты... Может быть перевести в растр с прозрачностью, будет меньше памяти занимать.

 

[_MBK_]

Иногда лучше жевать

 

[Rusta]

Добавьте в начало кода
Optimization = True
в конец
Optimization = False
ActiveWindow.Refresh
Refresh
сравните время.
Если не сильно помогло, будем думать дальше

Большое спасибо за совет.
Опция действительно помогает, отключает вывод на экран во время операций.
Теперь на файл с 10 000 квадратов тратится вместо 5 минут - 2 минуты. Хорошо но все же не айс.
Пришлось действовать, как любят наши говорить - ассиметрично, то есть зайти через задний проход.
Первично я в макросе же считываю файл и записываю временнsй файл в формате SVG ,
благо он тоже текстовый, а потом импортирую его в слой
Результат : файл с 10 000 квадратиков обрабатывается за 1.02 сек, файл с 20 000 квадратиков обрабатывается за 1.66 сек

Код, на будущее если кому то пригодиться на будущее для создания однотипных Shapes:

 

[Rusta]

Const pi = 3.14159265358979
    Dim File As String
    Dim FileSvg As String
    Dim FilePalette As String
    Dim Panno As layer
    Dim Data As String
    Dim X, Y, Angle As Single
    Dim clr As Integer
    Dim sy, sa, sx As Long
    Dim newDoc As Document
    Dim sh As Shape
    Dim fs As Variant
    Dim fileout As Variant
    Dim fs2 As Variant
    Dim filetemp As Variant
    Dim pal As Palette
    Dim mc As New Color
    Dim svghead As String
    Dim id_file As Integer
    Dim point(4, 2) As Single
 
    File = CorelScriptTools.GetFileBox("File (*.mog)|*.mog|Text file(*.txt)|*.txt", "Load file", 0, "")
    If File = "" Then Exit Sub
 
    Set newDoc = CreateDocument
 
    newDoc.Unit = cdrMillimeter
    Set Panno = newDoc.ActivePage.ActiveLayer
    Panno.Name = "Panno"
 
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fileout = fs.OpenTextFile(File, 1)
 
    FileSvg = Left(File, Len(File) - 3) & "svg"
    Set fs2 = CreateObject("Scripting.FileSystemObject")
    Set filetemp = fs2.CreateTextFile(FileSvg, True)
 
    filetemp.writeline "<!DOCTYPE svg PUBLIC ""-//W3C//DTD SVG 1.1//EN"" ""http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd""> "
    filetemp.writeline "<!-- Creator: CorelDRAW -->"
    filetemp.writeline "<svg xmlns=""SVG namespace"" xml:space=""preserve"" width=""210mm"" height=""297mm"" "
    filetemp.writeline "shape-rendering=""geometricPrecision""  fill-rule=""evenodd"" clip-rule=""evenodd"" viewBox = ""0 0 210 297"" "
    filetemp.writeline "xmlns:xlink=""XLink namespace"">"
    filetemp.writeline "<g id=""" & id_file & """> "
    filetemp.writeline "  <metadata id=""CorelCorpID_0Corel-Layer""/>"
 
    While Not fileout.AtEndOfStream
        sx = 1
        Data = fileout.ReadLine
        sx = InStr(sx, Data, " ", vbTextCompare)
        X = CSng(Left(Data, sx))
        sy = InStr(sx + 1, Data, " ", vbTextCompare)
        Y = CSng(Mid(Data, sx + 1, sy - sx))
        sa = InStr(sy + 1, Data, " ", vbTextCompare)
        'Angle = CSng(Mid(Data, sy + 1, sa - sy))
        Angle = 0.01745 * (45 + CSng(Mid(Data, sy + 1, sa - sy))) ' radian
        clr = CInt(Right(Data, Len(Data) - sa))
     
        mc.RGBValue = AColors(clr)
     
        point(1, 1) = X + 7.071 * Cos(Angle)
        point(1, 2) = Y + 7.071 * Sin(Angle)
        point(2, 1) = X + 7.071 * Cos(Angle + pi / 2)
        point(2, 2) = Y + 7.071 * Sin(Angle + pi / 2)
        point(3, 1) = X + 7.071 * Cos(Angle + pi)
        point(3, 2) = Y + 7.071 * Sin(Angle + pi)
        point(4, 1) = X + 7.071 * Cos(Angle - pi / 2)
        point(4, 2) = Y + 7.071 * Sin(Angle - pi / 2)
     
        filetemp.writeline "<polygon fill=""#" & Hex(mc.RGBRed) & Hex(mc.RGBGreen) & Hex(mc.RGBBlue) & """ points=""" & Str(point(1, 1)) & "," & Str(point(1, 2)) & " " _
        & Str(point(2, 1)) & "," & Str(point(2, 2)) & " " _
        & Str(point(3, 1)) & "," & Str(point(3, 2)) & " " _
        & Str(point(4, 1)) & "," & Str(point(4, 2)) & """/>"

    Wend
    fileout.Close
    filetemp.writeline "</g>" & vbCrLf & "</svg>"
    filetemp.Close
 
    Panno.Import FileSvg
 
    Kill FileSvg

 

[_MBK_]

ассиметрично, то есть зайти через задний проход.

На самом деле, данное решение самое прямое, ибо для скорости в программе желательно минимизировать использование VBA
В данном случае вы убиваете двух зайцев - импорт и создание шейпов у вас выполняет нативный фильтр импорта svg, операцию создания svg легко тоже при особом желании запихнуть во внешний нативный модуль.