![]() |
#1
|
||||
|
||||
![]()
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 |
#2
|
||||
|
||||
![]()
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.
Code:
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 -Shelby |
#3
|
||||
|
||||
![]()
HI.
When I use it with this code I get a crash. I guess I'm asking to much...lol I changed this: Code:
Set sLine = ActiveLayer.CreateLineSegment(x1, y1, x, y) Code:
Set sLine = ActiveVirtualLayer.CreateLineSegment(x1, y1, x, y) Here's the code: 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 |
#4
|
||||
|
||||
![]()
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.
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 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 -Shelby |
#5
|
||||
|
||||
![]()
Hi.
Ah. Nice. So the command group was causing the crash. Thanks! ~John |
![]() |
Currently Active Users Viewing This Thread: 1 (0 members and 1 guests) | |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
Export creation of puzzle as a SWF | Jean-Paul Grimaldi | Jigsaw Puzzle Creator | 1 | 16-01-2011 19:16 |
Changing selection when two-shape group loses one shape | Joe | CorelDRAW/Corel DESIGNER VBA | 1 | 19-02-2009 03:50 |
Help - Creation of GMS - IVGGMSManager | wOxxOm | CorelDRAW/Corel DESIGNER VBA | 6 | 02-07-2007 13:44 |
pdf file creation queries | ozambersand | General | 0 | 12-05-2005 04:20 |
New document creation problem | ddonnahoe | CorelDRAW/Corel DESIGNER VBA | 2 | 20-11-2004 01:26 |