Sub RemoveTransparencyFromOutlines2() For i = 1 To shapes.count With shapes(i) If .Outline.Transparency > 0 Then .Outline.Transparency = 0 End If End With Next iEnd Sub
This is not working, Please someone help
The outline in CoreDraw dont have a transparency parameter. End of macro.
but we have 2 options while using the transparency tool.... fill or outline or both
Yes working sir, Thanking you
please correct this script
Sub Transparency_RemoveBoth() Dim s As Shape Dim p As Integer Dim srOutlines As shapeRange Dim ob As Integer ob = 0 For p = 1 To ActiveDocument.Pages.Count ActiveDocument.Pages(p).Activate Set srOutlines = FindAllShapes().FindShapes(Query:="@com.transparency.type > 0") For Each s In srOutlines.shapes s.Transparency.AppliedTo = cdrApplyToFill s.Transparency.ApplyNoTransparency ' Remove transparency for the fill s.Outline.Transparency.ApplyNoTransparency ' Remove transparency for the outline Next s ob = ob + srOutlines.Count srOutlines.RemoveAll Next pEnd Sub
Function FindAllShapes() As shapeRange Dim s As Shape Dim srPowerClipped As New shapeRange Dim sr As shapeRange Dim srAll As New shapeRange If ActiveSelection.shapes.Count > 0 Then Set sr = ActiveSelection.shapes.FindShapes() Else Set sr = ActivePage.shapes.FindShapes() End If Do For Each s In sr.shapes.FindShapes(Query:="!@com.powerclip.IsNull") srPowerClipped.AddRange s.PowerClip.shapes.FindShapes() Next s srAll.AddRange sr sr.RemoveAll sr.AddRange srPowerClipped srPowerClipped.RemoveAll Loop Until sr.Count = 0 Set FindAllShapes = srAll For Each s In srAll s.AddToSelection Next s ActiveSelection.Transparency.AppliedTo = cdrApplyToFillEnd Function
1) This scirpt is not removing the fill transparency2) Error is showing here : Set srOutlines = FindAllShapes().FindShapes(Query:="@com.transparency.type > 0")please kindly correct this .
Do you want to remove all transparencies? And outline and fills?
yes
like thisremTrans.zip
any possible to provide the script
CorelDraw - Alt+F11
and look as much as you want :)
Thanking you
sir if any active selection is existed, then it is not removing the powerclip outline transparency. if no selection, then it is removing everything. please kindly correct when having selection, powerclip outline transparency also must be removed.
Sub RemoveTrans() Dim s As Shape, sC As Shape, p As Integer, srOut As shapeRange, srPC As shapeRange Dim OrigSelection As shapeRange Dim selectedShapes As shapeRange Optimization = True: EventsEnabled = False ActiveDocument.BeginCommandGroup "TrNO" Set OrigSelection = ActiveSelectionRange If OrigSelection.shapes.Count > 0 Then Set selectedShapes = OrigSelection Else Set selectedShapes = FindAllShapes() End If For Each s In selectedShapes If s.Transparency.Type > 0 Then s.Transparency.ApplyNoTransparency End If If Not s.PowerClip Is Nothing Then s.PowerClip.EnterEditMode Set srPC = s.PowerClip.shapes.All If srPC.Count > 0 Then For Each sC In srPC If sC.Transparency.Type > 0 Then sC.Transparency.ApplyNoTransparency End If Next sC End If s.PowerClip.LeaveEditMode End If Next s ActiveDocument.EndCommandGroup ActiveDocument.ClearSelection Optimization = False: EventsEnabled = True ActiveWindow.Refresh: Application.RefreshEnd Sub
Function FindAllShapes() As shapeRange Dim s As Shape, srPowerClipped As New shapeRange, sr As shapeRange, srAll As New shapeRange Set sr = ActivePage.shapes.FindShapes() Do For Each s In sr.shapes.FindShapes(Query:="!@com.powerclip.IsNull") srPowerClipped.AddRange s.PowerClip.shapes.FindShapes() Next s srAll.AddRange sr sr.RemoveAll sr.AddRange srPowerClipped srPowerClipped.RemoveAll Loop Until sr.Count = 0 Set FindAllShapes = srAllEnd Function
see here
scroll all the way down to the bottom and you'll see DelTransOut2.zip