1
1

Shapes_Border.bas 1.4 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546
  1. Sub Shapes_Border()
  2. '// 建立文件 testfile.txt 输出物件坐标信息
  3. Set fs = CreateObject("Scripting.FileSystemObject")
  4. Set f = fs.CreateTextFile("R:\testfile.txt", True)
  5. ActiveDocument.Unit = cdrMillimeter
  6. Dim OrigSelection As ShapeRange
  7. Set OrigSelection = ActiveSelectionRange
  8. '// 代码运行时关闭窗口刷新
  9. Application.Optimization = True
  10. ' 当前选择物件的范围边界
  11. set_lx = OrigSelection.LeftX
  12. set_rx = OrigSelection.RightX
  13. set_by = OrigSelection.BottomY
  14. set_ty = OrigSelection.TopY
  15. set_cx = OrigSelection.CenterX
  16. set_cy = OrigSelection.CenterY
  17. radius = 20
  18. Dim s1 As Shape
  19. cnt = 1
  20. For Each Target In OrigSelection
  21. Set s1 = Target
  22. lx = s1.LeftX
  23. rx = s1.RightX
  24. by = s1.BottomY
  25. ty = s1.TopY
  26. If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - by) _
  27. < radius Or Abs(set_ty - ty) < radius Then
  28. '// 遍历物件,输出左下-右下-左上-右上四点坐标
  29. f.WriteLine (cnt & "号物件修改颜色: 绿色")
  30. s1.Fill.UniformColor.CMYKAssign 60, 0, 100, 0
  31. End If
  32. cnt = cnt + 1
  33. Next Target
  34. f.Close
  35. '// 代码操作结束恢复窗口刷新
  36. Application.Optimization = False
  37. ActiveWindow.Refresh
  38. Application.Refresh
  39. End Sub