如何反向思考複製格式的方式!

yenwang

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

lpk187

回復 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

回復 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

回復 3# GBKEE


謝謝大家的幫助
有清楚且可以解決問題了
感恩

yenwang

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

GBKEE

回復 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

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