OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Thread Tools Search this Thread Display Modes
Old 01-01-2020, 15:23
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
Join Date: Apr 2004
Posts: 155
Default Convert to 2019


I have this bit of code to import a file and
low & behold doesnt work in 2019. Works fine in x4.

Anyone for updated code?

Somefile.cdr would need to be an object saved to import.

Sub import_Somfile()
On Error GoTo myerr
 ActiveDocument.ReferencePoint = cdrCenter
Dim x As Double, y As Double, Shift As Long, b As Boolean
b = False
b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorWinCross)
Optimization = True
ActiveDocument.BeginCommandGroup "import"
ActiveLayer.Import "C:SOMEFILE.cdr"
ActiveShape.SetPosition x, y
Optimization = False
End Sub

All variations codewise welcome.

Using X4 & 2019 2020... yikes 2021

Last edited by dungbtl; 01-01-2020 at 15:26.
Reply With Quote
Old 01-01-2020, 15:32
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
Join Date: Apr 2004
Posts: 155
Default Same Color Select

Not sure who made this old classic but I like it.

By shortcut key I can select the same color of either
Fill or Outline. Quite handy for my needs.

Doesnt work in 2019

See attached file

Attached Files
File Type: gms sameColorSelect.gms (34.5 KB, 604 views)
Using X4 & 2019 2020... yikes 2021
Reply With Quote
Old 04-01-2020, 05:05
shark shark is offline
Senior Member
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146


selectSameColor - remove line Application.CorelScript.RedrawScreen in boostFinish and add PtrSafe between Declare and Function

import_Somfile - change to ActiveLayer.Import "C:\SOMEFILE.cdr"
and remove Optimization = True (and Optimization = False)

tested in CD X8, all works. check if it works in CD 2019 and write about the results
Reply With Quote
Old 12-01-2020, 03:45
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
Join Date: Apr 2004
Posts: 155

import_Somefile works.... cool!

Did the changes and it became usable but no change.
The original object just stayed the same, no pointer
to select other objects color

Public Declare PtrSafe Function GetAsyncKeyState& Lib "user32" (ByVal vKey&) ' 01-12-20 - Added PtrSafe  between declare & function

Sub selectSameFillColor() ' ====================
   selectSameColor True, False
End Sub
Sub selectSameFillAndOutline() ' ====================
   selectSameColor True, True
End Sub
Sub selectSameOutline() ' ====================
   selectSameColor False, True
End Sub

Private Sub selectSameColor(Optional checkFill As Boolean = True, _
                     Optional checkOutline As Boolean = False) ' ====================
   Dim sr As ShapeRange, sh As Shape, clr As New Color, srg As ShapeRange
   Dim seekFillColor As New Color, seekOutlineColor As New Color
   Dim found As New ShapeRange, stat As AppStatus

   If ActiveShape Is Nothing Then Beep: Exit Sub

   s = "1"
   If (GetAsyncKeyState(&H91) And 1) <> 0 Then 'VK_SCROLL=0x91
      s = InputBox("Difference allowed (0-100%):" & vbCrLf & "(Negative = select in groups)", "Select same color", 0)
      If s = "" Then Exit Sub
   End If
   diff = Int(Val(s)): selectInGroups = (diff < 0): diff = Abs(diff)
   seekShapeType = ActiveShape.Type: seekFillType = -1: seekOutlineType = -1
   Select Case seekShapeType
      Case cdrCurveShape, cdrCustomShape, cdrEllipseShape, cdrPerfectShape, _
           cdrPolygonShape, cdrRectangleShape, cdrTextShape
         If checkFill Then
            seekFillType = ActiveShape.Fill.Type
            Select Case seekFillType
               Case cdrNoFill: '
               Case cdrUniformFill, cdrMonoBitmapFill
                  seekFillColor.CopyAssign ActiveShape.Fill.UniformColor
                  If diff > 0 Then seekFillColor.ConvertToCMYK
               Case cdrFountainFill:
               Case Else
                  MsgBox ("Unsupported type of fill."): Exit Sub
            End Select
         End If
         If checkOutline Then
            seekOutlineType = ActiveShape.Outline.Type
            If seekOutlineType <> cdrNoOutline Then
               seekOutlineColor.CopyAssign ActiveShape.Outline.Color
               If diff > 0 Then seekOutlineColor.ConvertToCMYK
            End If
         End If
   End Select
   On Error GoTo ErrHandler: boostStart
   Set stat = Application.Status: stat.BeginProgress CanAbort:=True
   If Not selectInGroups Then
      Set srg = ActivePage.SelectableShapes.All
      srg.RemoveRange ActivePage.FindShapes(, cdrGroupShape, False)
      Set sr = srg.Shapes.FindShapes(, , False)
      Set srg = Nothing
      Set sr = ActivePage.FindShapes
   End If
   sr.AddRange ActiveDocument.Pages(0).DesktopLayer.FindShapes(, , selectInGroups)
   For Each sh In sr
      Select Case sh.Type
      Case cdrCurveShape, cdrCustomShape, cdrEllipseShape, cdrPerfectShape, _
           cdrPolygonShape, cdrRectangleShape, cdrTextShape
         passFill = False: passOutline = False
         If checkFill And sh.Fill.Type = seekFillType Then
            Select Case seekFillType
               Case cdrNoFill
                  passFill = True
               Case cdrUniformFill, cdrMonoBitmapFill
                  If diff = 0 Then
                     passFill = sh.Fill.UniformColor.IsSame(seekFillColor)
                     clr.CopyAssign sh.Fill.UniformColor
                     If clr.Type <> cdrColorCMYK Then clr.ConvertToCMYK
                     'distance = clr.GetColorDistanceFrom(seekFillColor)
                     'MsgBox distance & vbCrLf & seekFillColor.ToString & vbCrLf & clr.ToString & vbCrLf & diff
                     'passFill = clr.GetColorDistanceFrom(seekFillColor) <= dist
                     passFill = diff >= Sqr((clr.CMYKCyan - seekFillColor.CMYKCyan) ^ 2 + _
                         (clr.CMYKMagenta - seekFillColor.CMYKMagenta) ^ 2 + _
                         (clr.CMYKYellow - seekFillColor.CMYKYellow) ^ 2 + _
                         (clr.CMYKBlack - seekFillColor.CMYKBlack) ^ 2)
                  End If
            End Select
         End If
         If checkOutline And sh.Outline.Type = seekOutlineType Then
            Select Case seekOutlineType
               Case cdrNoOutline
                  passOutline = True
               Case cdrOutline
                  If diff = 0 Then
                     passOutline = sh.Outline.Color.IsSame(seekOutlineColor)
                     clr.CopyAssign sh.Outline.Color
                     If clr.Type <> cdrColorCMYK Then clr.ConvertToCMYK
                     'distance = clr.GetColorDistanceFrom(seekOutlineColor)
                     'passOutline = clr.GetColorDistanceFrom(seekOutlineColor) <= dist
                     passOutline = diff >= Sqr((clr.CMYKCyan - seekOutlineColor.CMYKCyan) ^ 2 + _
                         (clr.CMYKMagenta - seekOutlineColor.CMYKMagenta) ^ 2 + _
                         (clr.CMYKYellow - seekOutlineColor.CMYKYellow) ^ 2 + _
                         (clr.CMYKBlack - seekOutlineColor.CMYKBlack) ^ 2)
                  End If
            End Select
         End If
         If VBA.IIf(checkFill, passFill, True) And VBA.IIf(checkOutline, passOutline, True) _
            Then found.Add sh
      Case Else
         If sh.Type = seekShapeType Then found.Add sh
      End Select
   Next sh
   If found Is Nothing _
      Then ActiveDocument.ClearSelection _
      Else found.CreateSelection
   stat.EndProgress: boostFinish: Exit Sub
   MsgBox "Unexpected error occured: " & Err.Description & vbCrLf & Err.Source, vbCritical
   stat.EndProgress: Resume ExitSub
End Sub

Public Sub boostStart(Optional ByVal unDo As String = "") ' ====================
   If unDo <> "" Then ActiveDocument.BeginCommandGroup unDo
   Optimization = True
   EventsEnabled = False
   ActiveDocument.PreserveSelection = False
End Sub

Public Sub boostFinish(Optional ByVal endUndoGroup As Boolean = False) ' ====================
   Dim cs As Object
   ActiveDocument.PreserveSelection = True
   EventsEnabled = True
   Optimization = False
   'Application.CorelScript.RedrawScreen - Removed 01-12-20
   If endUndoGroup Then ActiveDocument.EndCommandGroup
End Sub

Function keyPressed(ByVal key&) As Boolean
   keyPressed = (GetAsyncKeyState(key) And &HFFFF8000) <> 0
   End Function

End Sub
Using X4 & 2019 2020... yikes 2021

Last edited by dungbtl; 12-01-2020 at 04:27.
Reply With Quote
Old 12-01-2020, 04:29
dungbtl's Avatar
dungbtl dungbtl is offline
Senior Member
Join Date: Apr 2004
Posts: 155

Im stumped on this one:

It's all in Red starting with Dim
Well, almost all...

Any time I post code here in [CODE button], there are (2) * * before each line
but normal when just pasting.

Strange... I had to paste it into this browser in order to copy it and paste into corel.
Couldnt use it from anything else or it came up red and unusable. Was there formatting
that didnt translate? Who knows it works now.

Sub TextShapeColor()
Dim srText As ShapeRange
Dim srShapes As ShapeRange
Dim cColor As New Color

'Simple check to see if anything is selected
If ActiveSelection.Shapes.Count = 0 Then
MsgBox "Please select some text or shapes.", , "TextShapeColor"
Exit Sub 'If nothing is found give error and exit program
End If

Set srText = ActiveSelection.Shapes.FindShapes(, cdrTextShape, True) 'Find all the text object in current selection
Set srShapes = ActiveSelection.Shapes.FindShapes() 'Find all the shapes in the current selection (This digs into groups)

srShapes.RemoveRange srShapes.Shapes.FindShapes(, cdrGroupShape, True) 'Remove the groups
srShapes.RemoveRange srText 'Remove The text
If cColor.UserAssignEx = False Then 'User closed the dialog without selection a color
MsgBox "Please select a color.", , "TextShapeColor" 'Error for no color selection
Optimization = True 'Stops the Flashing by turning of screen redraws
ActiveDocument.BeginCommandGroup "Text Shapes Color" 'Begins Undo
On Error GoTo ErrHandler
srShapes.SetOutlineProperties , , cColor 'Set the ouline color of the shapes
srText.ApplyUniformFill cColor 'Set the fill color of the Text
End If

ActiveDocument.EndCommandGroup 'End Undo Group
Optimization = False 'Turn screen redraws back on
ActiveWindow.Refresh 'Refresh the Window
Application.Refresh 'Refresh the Open Dockers
Exit Sub

ErrHandler: 'Just in case we screwed up
MsgBox "Error occured: " & Err.Description

Resume ExitSub

End Sub
Using X4 & 2019 2020... yikes 2021

Last edited by dungbtl; 12-01-2020 at 06:14.
Reply With Quote

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
Convert images to CMYC mateushenrico CorelDRAW/Corel DESIGNER VBA 10 19-01-2012 15:56
Draw 12 Convert to curves name bug? jlorbz CorelDRAW/Corel DESIGNER VBA 6 22-03-2010 12:07
Convert font to curves Panjtan CorelDRAW/Corel DESIGNER VBA 2 15-10-2007 23:43
Convert CMYK to RGB jooksingjai General 1 31-07-2007 00:07
How do convert to duotone Michael Cervantes CorelDRAW/Corel DESIGNER VBA 2 25-01-2007 10:42

All times are GMT -5. The time now is 06:15.

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