макрос: прозрачные края

[wOxxOm]

Делает прозрачными только края объекта. Спрашивает сколько на край - так же как в dropshadow (видимо в процентах от исходного размера фигуры)

первая проба.

Sub transparentEdge()
   Const dpi& = 300
   Dim origSR As New ShapeRange, sr As ShapeRange, sh As Shape, sh2 As Shape, toSel As New ShapeRange
   Dim eff As Effect, tmp$, feather&, s$
   Set origSR = ActiveSelectionRange
   If origSR.Count = 0 Then Exit Sub
   
   On Error Resume Next
   
   feather = Val(GetSetting("CorelDRAW", "TransparentEdges", "Feather", "5"))
   feather = IIf(feather <= 0 Or feather > 99, 5, feather)
   s = InputBox("Feather transparency", "Transparent EDGES", CStr(feather))
   If Trim$(s) = "" Then Exit Sub
   feather = Val(s)
   If feather <= 0 Or feather > 99 Then Exit Sub
   SaveSetting "CorelDRAW", "TransparentEdges", "Feather", CStr(feather)
   
   Optimization = True
   EventsEnabled = False
   ActiveDocument.SaveSettings
   ActiveDocument.PreserveSelection = False
   ActiveDocument.BeginCommandGroup "Transparent edges"
   
   For Each sh In origSR
      Set eff = sh.CreateDropShadow(cdrDropShadowFlat, 100, feather, 0#, 0#, CreateCMYKColor(0, 0, 0, 100), cdrFeatherInside, cdrEdgeLinear, MergeMode:=cdrMergeNormal)
      Set sr = eff.Separate: Set eff = Nothing
      Set sh2 = sr(1).ConvertToBitmap(8, True, , False, dpi): sh2.ApplyEffectInvert
      tmp = Environ$("temp"): If right$(tmp, 1) <> "\" Then tmp = tmp + "\"
      tmp = tmp + Hex(Timer) + ".tif"
      
      sh2.Bitmap.SaveAs(tmp, cdrTIFF, cdrCompressionLZW).Finish
      sh2.Delete
      err.Clear: FileSystem.GetAttr tmp: If err.Number Then Debug.Print "Error: " + tmp: GoTo NextShape
      
      With sr(2).Transparency.ApplyPatternTransparency(cdrBitmapPattern, tmp, 0, 0, 100, True)
         .MirrorFill = False
         .TileOffsetType = cdrTileOffsetRow
         .TileOffset = 0
         .RotationAngle = 0#
         .SkewAngle = 0
         .TileWidth = sh.SizeWidth
         .TileHeight = sh.SizeHeight
         .OriginX = 0#
         .OriginY = 0#
      End With
      With sr(2).Transparency
         If Application.VersionMajor = 13 Then .MergeMode = cdrMergeMultiply
         .AppliedTo = cdrApplyToFillAndOutline
      End With
      toSel.Add sr(2)
      FileSystem.Kill tmp
NextShape:
   Next sh
   
   ActiveDocument.EndCommandGroup
   ActiveDocument.PreserveSelection = True
   ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   toSel.CreateSelection
   Application.CorelScript.RedrawScreen
   End Sub

доработаем?

 

[Sanchos]

Ответ: макрос: прозрачные края

ApplyPatternTransparency(cdrBitmapPattern, tmp

В сложных объктас маска сдвигается...

 

[wOxxOm]

Ответ: макрос: прозрачные края

Лишний пробел вставил глюк форума. Про группированные объекты знаю, а что делать?

 

[wOxxOm]

Ответ: макрос: прозрачные края

вот здесь скомпилированная -
http://recentfiles.sbn.bz/misc/wx_TransparentEdge.exe