Board logo

標題: 如何反向思考複製格式的方式! [打印本頁]
作者: yenwang    時間: 2015-3-5 19:15     標題: VBA取得線條的座標值!!

我想使用VBA將工作表中所畫的線條
其頭尾的座標值記錄下來
但是不清楚要如何動作
Selection.ShapeRange.Name 可以取得線條的名稱
那要使用哪個指令，才能取得線條，頭尾兩點的座標資料呢??
作者: lpk187    時間: 2015-3-6 19:53

回復 1# yenwang


Dim sp As Shape
For Each sp In sheet1.Shapes
    K = K + 1
    Cells(K + 1, "A") = sp.Name
    Cells(K + 1, "b") = sp.Type
    Cells(K + 1, "c") = sp.Top
    Cells(K + 1, "d") = sp.Left
    Cells(K + 1, "e") = sp.Height
    Cells(K + 1, "F") = sp.Width
Next

給你參考
作者: GBKEE    時間: 2015-3-7 06:05

回復 1# yenwang
試試看
  1. Option Explicit
  2. Sub Ex()
  3.    Dim x As Single, y As Single, x1 As Single, y1 As Single
  4.    Dim S As Shape
  5.    ActiveSheet.Shapes.SelectAll
  6.    Selection.Delete
  7.    Set S = ActiveSheet.Shapes.AddLine(209.4, 160.2, 370.8, 223.2)
  8.    With S
  9.         x = .Left
  10.         y = .Top
  11.         x1 = x + .Width
  12.         y1 = y + .Height
  13.         
  14.     End With
  15.     Set S = ActiveSheet.Shapes.AddLine(x, y + 20, x1, y1 + 20) '往下20點新增線條
  16. End Sub
複製代碼
作者: yenwang    時間: 2015-3-7 08:38

回復 3# GBKEE


謝謝大家的幫助
有清楚且可以解決問題了
感恩
作者: yenwang    時間: 2015-3-7 08:43     標題: 如何反向思考複製格式的方式!

由於現在的EXCEL的線條複製格式上
需要先在格式來源上點選
然後複製格式後
再點選要變更格式的線條
我想請問
有辦法反向思考嗎??
因為現在我要修改的格式可能有幾十條線條或是多邊形
我想先利用選取的方式
將這幾十線條或多邊形選取
然後按下巨集後
則要求選取預變成目標格式的線條
然後就是這幾十線條或多邊形的線型就依照所選取的目標格式修改
有辦法這樣子寫程式嗎???
作者: GBKEE    時間: 2015-3-9 12:01

回復 1# yenwang
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Sp As Object
  4.     Dim A(1 To 4), i, b(1 To 4)
  5.     A(1) = Array([D5].Left, [D5].Top)
  6.     A(2) = Array([D10].Left, [D10].Top)
  7.     A(3) = Array([H10].Left, [H10].Top)
  8.     A(4) = Array([H5].Left, [H5].Top)
  9.     ActiveSheet.Shapes.SelectAll
  10.     Selection.Delete
  11.     For i = 1 To UBound(A)
  12.         With ActiveSheet.Shapes.AddLine(A(i)(0), A(i)(1), A(IIf(i < UBound(A), i + 1, 1))(0), A(IIf(i < UBound(A), i + 1, 1))(1))
  13.         b(i) = .Name
  14.         End With
  15.     Next
  16.     Set Sp = ActiveSheet.Shapes.Range(b)
  17.     With Sp
  18.         .Fill.Transparency = 0#
  19.         .Line.Weight = 4.5
  20.         .Line.ForeColor.SchemeColor = 10
  21.     End With
  22.     Stop
  23.     A(1) = Array(0, 3, 5, 7)
  24.     For i = 1 To Sp.Count
  25.         With Sp(i)
  26.             .Fill.Transparency = 0
  27.             .Line.Weight = A(1)(i - 1)
  28.             .Line.ForeColor.SchemeColor = A(1)(i - 1) + 10
  29.             .Line.BeginArrowheadLength = msoArrowheadLengthMedium
  30.             .Line.EndArrowheadWidth = msoArrowheadWidthMedium
  31.             .Line.EndArrowheadStyle = msoArrowheadOval
  32.         End With
  33.     Next
  34. End Sub
複製代碼
作者: yenwang    時間: 2015-3-10 22:41

有範例下載看嗎？我都試不成功！



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)