Not log or Un-log shape creation?

[runflacruiser]

Hi.
How can I create multiple shapes using a loop and do events.

I do want to see the items created on the screen.

When esc is pressed only use the last shape that was generated in the loop.
All others generated while using the do event will not be recorded into undo list.
Therefore pressing undo would only delete this final shape and not all others generated in do events loop.

Such as virtual shapes?

~John

[shelbym]

Alright, the only issue I ran into was pressing the Esc key fast enough ;-) Because using VirtualShapes is so dang fast. So I simulate a keypress by just jumping out at a random number. If Esc (or in this case my random number) is not detected then I delete the shape and create a new one. Then I just log the final shape and you only get one undo. Hopefully it all makes sense.

Sub OptimizeVirtual()
    Dim i As Long, nStop As Long
    Dim x As Double, y As Double, r As Double
    Dim n As Long, num As Long
    Dim MaxX As Double, MaxY As Double, MaxR As Double
    Dim s As Shape
    
    MaxX = ActivePage.SizeWidth
    MaxY = ActivePage.SizeHeight
    MaxR = 1
    num = ActivePalette.ColorCount
    
    nStop = Rnd() * 100
    
    For i = 1 To 100
        x = Rnd() * MaxX
        y = Rnd() * MaxY
        r = Rnd() * MaxR
        n = CLng(Fix(Rnd() * num)) + 1
        Set s = ActiveVirtualLayer.CreateEllipse2(x, y, r)
        s.Fill.ApplyUniformFill ActivePalette.Color(n)
        
        If i = nStop Then 'Simulate Esc key press
            Exit For
        Else
            s.Delete
        End If
    Next i
    
    ActiveDocument.LogCreateShape s
    ActiveWindow.Refresh
End Sub

Hope that helps,

-Shelby

[runflacruiser]

HI.
When I use it with this code I get a crash.
I guess I'm asking to much...lol

I changed this:

Set sLine = ActiveLayer.CreateLineSegment(x1, y1, x, y)

to:

Set sLine = ActiveVirtualLayer.CreateLineSegment(x1, y1, x, y)

and then try to log shape at end....


Here's the code:

Option Explicit
Public Type lpPoint
    x As Long
    y As Long
End Type
Public BC As Double, AC As Double, AB As Double
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function GetCursorPos Lib "user32" (ByRef pos As lpPoint) As Boolean

Sub DrawLine()
    Dim p As lpPoint
    Dim curX As Double, curY As Double, start
    Dim s As Shape, l As Layer
    Dim bClick As Boolean, Shift&, x#, y#, i%, x1#, y1#
    Dim sLine As Shape
    
    On Error GoTo DrawGuideHorizontal_Error

    ActiveDocument.BeginCommandGroup "linemaker"
    bClick = False
    bClick = ActiveDocument.GetUserClick(x, y, Shift, 10, True, cdrCursorEyeDrop)
    If Not bClick Then
        x1 = x: y1 = y
    End If
    
    GetCursorPos p
    ActiveDocument.ActiveWindow.ScreenToDocument p.x, p.y, x, y
     
        Do While GetAsyncKeyState(vbKeyEscape) = 0
            
            DoEvents
            GetCursorPos p
            ActiveDocument.ActiveWindow.ScreenToDocument p.x, p.y, x, y
            If curX <> x Or curY <> y Then
                If Not sLine Is Nothing Then sLine.Delete
                Set sLine = ActiveVirtualLayer.CreateLineSegment(x1, y1, x, y)
            End If
            If GetAsyncKeyState(vbKeyRButton) Then Exit Sub
        Loop
        ActiveDocument.EndCommandGroup
   On Error GoTo 0
   Exit Sub

DrawGuideHorizontal_Error:

   ActiveDocument.EndCommandGroup
        
    End Sub

~John

[shelbym]

Asking to much, never, you just need to take out the CommandGroup, since we will not be using it to hide the undos. Then clean up the code a bit add a Refresh or two and I think you will have your desired result.

Option Explicit

Public Type lpPoint
    x As Long
    y As Long
End Type
Public BC As Double, AC As Double, AB As Double
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Declare Function GetCursorPos Lib "user32" (ByRef pos As lpPoint) As Boolean

Sub DrawLine()
     Dim p As lpPoint
     Dim curX As Double, curY As Double, start
     Dim s As Shape, l As Layer
     Dim bClick As Boolean, Shift&, x#, y#, i%, x1#, y1#
     Dim sLine As Shape
    
     bClick = False
     bClick = ActiveDocument.GetUserClick(x, y, Shift, 10, True, cdrCursorEyeDrop)
     If Not bClick Then
         x1 = x: y1 = y
     End If
     
     GetCursorPos p
     ActiveDocument.ActiveWindow.ScreenToDocument p.x, p.y, x, y
      
         Do While GetAsyncKeyState(vbKeyEscape) = 0
             DoEvents
             GetCursorPos p
             ActiveDocument.ActiveWindow.ScreenToDocument p.x, p.y, x, y
             If curX <> x Or curY <> y Then
                 If Not sLine Is Nothing Then sLine.Delete
                 Set sLine = ActiveVirtualLayer.CreateLineSegment(x1, y1, x, y)
             End If
             If GetAsyncKeyState(vbKeyRButton) Then Exit Do
             ActiveWindow.Refresh
         Loop
    
    ActiveDocument.LogCreateShape sLine
    ActiveWindow.Refresh
  End Sub

Hope that helps,

-Shelby

[runflacruiser]

Hi.
Ah. Nice.
So the command group was causing the crash.
Thanks!
~John