OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Corel User Forums > CorelDRAW > Feature requests/wishlist

Reply
 
Thread Tools Search this Thread Display Modes
  #21  
Old 05-05-2010, 21:43
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Try this.
I added a few features and a form.

Form code
Code:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Sub cmdStart_Click()
    DeleteSmall.RemoveSmallStuff
End Sub
Public Sub LowLevelRepaint()
    Dim hWnd As Long
    hWnd = FindWindow("ThunderDFrame", Me.Caption)
    If hWnd <> 0 Then
        UpdateWindow hWnd
End If
End Sub
Public Sub RefreshForm()
   LowLevelRepaint
End Sub

Private Sub UserForm_Initialize()
    txtTol.Value = GetSetting("removeSmall", "Pref", "tolerance", 0.001)
    lblProgress.Width = 0
    Label1.Width = 0
    rdAll.Value = GetSetting("removeSmall", "Pref", "scope_all", False)
    rdSel.Value = GetSetting("removeSmall", "Pref", "scope_sel", True)
    chkOptim.Value = GetSetting("removeSmall", "Pref", "optimize", False)
End Sub

Module Code:
Code:
Option Explicit
Sub GO()
    If ActiveDocument Is Nothing Then
        MsgBox "Please open a document in order to use macro.", vbCritical
    Else
        frmMain.Show vbModeless
    End If
End Sub

Public Function RemoveSmallSubpaths(s As Shape, tol As Double) As Boolean
    Dim i As Integer

    If s.Type <> cdrCurveShape Then
        s.ConvertToCurves
    End If
    For i = s.Curve.SubPaths.Count To 1 Step -1
         If s.Curve.SubPaths(i).Length < tol Then
             s.Curve.SubPaths(i).Delete
             RemoveSmallSubpaths = True
         End If
     Next i
     
End Function

Public Sub RemoveSmallStuff()
    ActiveDocument.BeginCommandGroup "Remove Small Shapes"
    Dim sr As ShapeRange
    Dim s As Shape
    Dim i As Long
    Dim x As Long
    
    SaveSetting "removeSmall", "Pref", "tolerance", frmMain.txtTol.Value
    SaveSetting "removeSmall", "Pref", "scope_sel", frmMain.rdSel.Value
    SaveSetting "removeSmall", "Pref", "scope_all", frmMain.rdAll.Value
    SaveSetting "removeSmall", "Pref", "optimize", frmMain.chkOptim.Value
    
    x = 0
    frmMain.lblProgress.Width = 64.3
    frmMain.Label1.Width = 45.9
    
    If frmMain.chkOptim.Value Then
        Optimization = True
    End If
    
    If frmMain.rdSel Then
        Set sr = ActiveSelectionRange.Shapes.FindShapes
    Else
        Set sr = ActivePage.FindShapes
    End If
    
    For i = 1 To sr.Count
        If RemoveSmallSubpaths(sr(i), IIf(frmMain.txtTol.Value = "", 0.01, frmMain.txtTol.Value)) Then
            x = x + 1
        End If
        frmMain.lblProgress.Caption = i & " of " & sr.Count
        frmMain.RefreshForm
        
        If i = sr.Count Then
            frmMain.lblProgress.Width = 0
            frmMain.Label1.Width = 150
            frmMain.Label1.Caption = "Finished processing " & sr.Count & " shapes. " & vbNewLine & _
            x & " shapes were deleted."
        End If
    Next i
    
    If frmMain.chkOptim.Value Then
        Optimization = False
        Application.Refresh
    End If
    
    ActiveDocument.EndCommandGroup
End Sub
You can use attached gms too.

-John
Attached Files
File Type: gms deleteSmallObjects.gms (40.0 KB, 237 views)
Reply With Quote
  #22  
Old 05-05-2010, 21:45
gorgo gorgo is offline
Senior Member
 
Join Date: Feb 2010
Posts: 169
Default

WOAH! Will test it.

-Greg
Reply With Quote
  #23  
Old 05-05-2010, 23:40
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Future ideas:

Also Choose from curve length(as present), shape area, shape w, shape h, for deleted items.

Anyone feel free to contribute ideas, or code this community macro...

-John
Reply With Quote
  #24  
Old 06-05-2010, 09:43
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default

oops..got this error while trying to clean some cad files.
Attached Images
  
Reply With Quote
  #25  
Old 06-05-2010, 10:06
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Do you know what type of object it stopped on?
You should be able to add an "on error resume next" as shown here, since the macro has no error handling at the moment. Add to same place as shown and retest.

Code:
Public Function RemoveSmallSubpaths(s As Shape, tol As Double) As Boolean
    On Error Resume Next
    Dim i As Integer

    If s.Type <> cdrCurveShape Then
        s.ConvertToCurves
    End If
    For i = s.Curve.SubPaths.Count To 1 Step -1
         If s.Curve.SubPaths(i).Length < tol Then
             s.Curve.SubPaths(i).Delete
             RemoveSmallSubpaths = True
         End If
     Next i
     
End Function
-John
Reply With Quote
  #26  
Old 06-05-2010, 10:21
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default

will use your error handling code.
here is where the error occurs...will try to find object causing error.
Attached Images
 
Reply With Quote
  #27  
Old 06-05-2010, 11:10
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

I think it might be better and faster to go by shape size instead of curve length.

This will work on everything and you won't have to convert to curves. Speed should increase greatly.

It's part of the add-on I suggested earlier. When I get time I'll add it. Unless anyone else wants to give it a go.

-John
Reply With Quote
  #28  
Old 07-05-2010, 13:40
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default delete small objects

Hi.
Ok try this...

Added options as described above plus saves form position.

-John
Attached Files
File Type: gms deleteSmallObjects.gms (30.0 KB, 226 views)
Reply With Quote
  #29  
Old 07-05-2010, 16:25
gorgo2 gorgo2 is offline
Senior Member
 
Join Date: Feb 2010
Posts: 107
Default

Quote:
Originally Posted by runflacruiser View Post
Hi.
Ok try this...

Added options as described above plus saves form position.

-John
Currently testing...found some lockups. Check your e-mail. I sent you a sample file to use with the macro and hopefully you can see what's up and stuff. Thanks John.

Greg
Attached Images
 
Reply With Quote
  #30  
Old 07-05-2010, 16:37
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Quick try the h,w, or area options and see if they will work for you.

Hmm. But no email.

-John
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Global Macro delete Michael Cervantes CorelDRAW/Corel DESIGNER VBA 17 16-11-2010 09:11
Find and delete objects with no fill or outline keytecstaff CorelDRAW/Corel DESIGNER VBA 17 23-06-2010 00:34
Delete Segment macro addendum request Rakker New product ideas 1 18-10-2008 16:47
Delete matching objects click101 CorelDRAW/Corel DESIGNER VBA 2 02-06-2008 17:14
Delete small objects macro Jeff Harrison New product ideas 3 19-05-2007 13:19


All times are GMT -5. The time now is 17:30.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com