Chèn Shape vào bảng tính theo vị trí của cell

phuvacgach · 29/1/13

Dear các bác,
Em muốn xác định vị trí một điểm (Bằng Pixcel) của trên bảng tính exel thì làm như thế nào?
Trong ví dụ em đưa trong bảng tính, em muốn xác định vị trí của điểm A góc trái trên cùng của ô E8?
Em cảm ơn cả nhà.

ndu96081631 · 29/1/13

phuvacgach đã viết:
Dear các bác,
Em muốn xác định vị trí một điểm (Bằng Pixcel) của trên bảng tính exel thì làm như thế nào?
Trong ví dụ em đưa trong bảng tính, em muốn xác định vị trí của điểm A góc trái trên cùng của ô E8?
Em cảm ơn cả nhà.

Mục đích cuối cùng của bạn là để làm gì? Nói luôn đi, mất công lại lòng vòng

phuvacgach · 29/1/13

ndu96081631 đã viết:
Mục đích cuối cùng của bạn là để làm gì? Nói luôn đi, mất công lại lòng vòng

Dạ,
Em muốn vẽ biểu đồ lines freeform từ điểm này tới điểm khác theo độ rộng của cột ạ.
Em vẽ lại trong file đính kèm.

ndu96081631 · 29/1/13

phuvacgach đã viết:
Dạ,
Em muốn vẽ biểu đồ lines freeform từ điểm này tới điểm khác theo độ rộng của cột ạ.
Em vẽ lại trong file đính kèm.

Range có thuộc tính Left và Top
Range(...).Top là cạnh trên của Range(...)
Range(...).Left là cạnh trái của Range(...)
Dựa vào Top và Left mà đặt object là được rồi

phuvacgach · 29/1/13

Sub Ve_hinh()
With ActiveSheet.Shapes.BuildFreeform(1, 289, 30)
.AddNodes 1, 1, 289, 75
.AddNodes 1, 1, 190, 82
.AddNodes 1, 1, 289, 90
.AddNodes 1, 1, 289, 120
.AddNodes 1, 1, 450, 128
.AddNodes 1, 1, 289, 135
.AddNodes 1, 1, 289, 180
.AddNodes 1, 1, 140, 188
.AddNodes 1, 1, 289, 195
.ConvertToShape
End With
End Sub

Dear anh,
Em muốn xác định điểm pixcel để áp dụng vào vẽ lines theo như code kiểu như trên.
Làm vậy em cần phải xác định được tọa độ 1 điểm theo pixcel?
Hình vẽ đồ thị chi tiết thì liên quan tới link bên dưới em đang hỏi.

http://www.giaiphapexcel.com/forum/showthread.php?76696-T%E1%BA%A1o-Shape-Line-trong-VBA
Em cảm ơn.

ndu96081631 · 30/1/13

phuvacgach đã viết:
Sub Ve_hinh()
With ActiveSheet.Shapes.BuildFreeform(1, 289, 30)
.AddNodes 1, 1, 289, 75
.AddNodes 1, 1, 190, 82
.AddNodes 1, 1, 289, 90
.AddNodes 1, 1, 289, 120
.AddNodes 1, 1, 450, 128
.AddNodes 1, 1, 289, 135
.AddNodes 1, 1, 289, 180
.AddNodes 1, 1, 140, 188
.AddNodes 1, 1, 289, 195
.ConvertToShape
End With
End Sub

Dear anh,
Em muốn xác định điểm pixcel để áp dụng vào vẽ lines theo như code kiểu như trên.
Làm vậy em cần phải xác định được tọa độ 1 điểm theo pixcel?
Hình vẽ đồ thị chi tiết thì liên quan tới link bên dưới em đang hỏi.

http://www.giaiphapexcel.com/forum/showthread.php?76696-Tạo-Shape-Line-trong-VBA
Em cảm ơn.

Để đơn giản hóa vấn đề tôi không dùng Freeform mà vẽ từng line rồi nối lại. Các line này sẽ dựa trên địa chỉ cell cụ thể
1> Function để vẽ lines:

Mã:

Function DrawLines(ParamArray rCells()) As Shape
  Dim wks As Worksheet, i As Long, Arr()
  On Error GoTo ExitFunc
  If IsArray(rCells) Then
    Set wks = rCells(0).Parent
    ReDim Arr(1 To UBound(rCells))
    For i = 1 To UBound(rCells)
      Arr(i) = wks.Shapes.AddConnector(1, rCells(i - 1).Left, rCells(i - 1).Top, rCells(i).Left, rCells(i).Top).Name
    Next
    Set DrawLines = wks.Shapes.Range(Arr).Group
  End If
ExitFunc:
End Function

2> Code chính của bạn
Ví dụ bạn muốn vẽ các đường thằng đi qua Top, Left của các cell G3, G5, E6, G7, G8, I9, G10, G12, D13, G14

Mã:

Sub Draw()
  DrawLines [G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14]
End Sub

Hàm DrawLines trả về kết quả là 1 Shape, vì thế sau khi vẽ xong, bạn hoàn toàn có thể format nó theo ý mình
Ví dụ:

Mã:

Sub Draw()
  With DrawLines([G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

phuvacgach · 30/1/13

Sub Draw()
Dim a()
ReDim a(1 To 3)
a(1) = [g3]
a(2) = [g5]
a(3) = [E6]
'With DrawLines([g3], [g5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
With DrawLines(a())
.Name = "Tia sét"
.Line.ForeColor.RGB = vbRed
.Line.Weight = 3
End With
End Sub

Dear anh,
Em cũng không rõ lắm về aRray nên có một câu hỏi nhờ anh giúp.
Em muốn gộp tất cả các Cells trên thành một mảng và cho vào funtions của anh.
Muốn như vậy thì cần phải sửa Funtion như thế nào không?
Em cảm ơn.

ndu96081631 · 31/1/13

phuvacgach đã viết:
Sub Draw()
Dim a()
ReDim a(1 To 3)
a(1) = [g3]
a(2) = [g5]
a(3) = [E6]
'With DrawLines([g3], [g5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14])
With DrawLines(a())
.Name = "Tia sét"
.Line.ForeColor.RGB = vbRed
.Line.Weight = 3
End With
End Sub

Dear anh,
Em cũng không rõ lắm về aRray nên có một câu hỏi nhờ anh giúp.
Em muốn gộp tất cả các Cells trên thành một mảng và cho vào funtions của anh.
Muốn như vậy thì cần phải sửa Funtion như thế nào không?
Em cảm ơn.

Vì mỗi phần tử của mảng là 1 Range nên câu lệnh a(1) = [g3] là sai hoàn toàn
Phải vầy:

Mã:

Set a(1) = [g3]
Set a(2) = [g5]
Set a(3) = [E6]

Đồng thời sửa lại hàm DrawLines

Mã:

Function DrawLines(ByVal aCells) As Shape
  Dim wks As Worksheet
  Dim i As Long, n As Long
  Dim rCel1, rCel2, Arr()
  On Error GoTo ExitFunc
  If IsArray(aCells) Then
    If TypeOf aCells(LBound(aCells)) Is Range Then
      Set rCel1 = aCells(LBound(aCells))
      Set wks = rCel1.Parent
    End If
    For i = LBound(aCells) + 1 To UBound(aCells)
      If TypeOf aCells(i) Is Range Then
        Set rCel2 = aCells(i)
        n = n + 1
        ReDim Preserve Arr(1 To n)
        Arr(n) = wks.Shapes.AddConnector(1, rCel1.Left, rCel1.Top, rCel2.Left, rCel2.Top).Name
        Set rCel1 = aCells(i)
      End If
    Next
    If n > 1 Then
      Set DrawLines = wks.Shapes.Range(Arr).Group
    Else
      Set DrawLines = wks.Shapes(Arr(UBound(Arr)))
    End If
  End If
ExitFunc:
End Function

Còn code của bạn thì sửa thành:

Mã:

Sub Draw2()
  Dim a()
  ReDim a(1 To 3)
[COLOR=#ff0000]  Set a(1) = [G3]
  Set a(2) = [G5]
  Set a(3) = [E6][/COLOR]
  With DrawLines(a())
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

Hoặc:

Mã:

Sub Draw2()
  Dim a
  a = Array([G3], [G5], [E6]) 
  With DrawLines(a)
    .Name = "Tia sét"
    .Line.ForeColor.RGB = vbRed
    .Line.Weight = 3
  End With
End Sub

-----------------------
Bạn cũng có thể sửa dòng:
wks.Shapes.AddConnector(1, rCel1.Left, rCel1.Top, rCel2.Left, rCel2.Top).Name
Thành:
wks.Shapes.AddLine(rCel1.Left, rCel1.Top, rCel2.Left, rCel2.Top).Name
Cho gọn

Truongan1996 · 20/1/22

ndu96081631 đã viết:
Để đơn giản hóa vấn đề tôi không dùng Freeform mà vẽ từng line rồi nối lại. Các line này sẽ dựa trên địa chỉ cell cụ thể
1> Function để vẽ lines:

Mã:

Function DrawLines(ParamArray rCells()) As Shape Dim wks As Worksheet, i As Long, Arr() On Error GoTo ExitFunc If IsArray(rCells) Then Set wks = rCells(0).Parent ReDim Arr(1 To UBound(rCells)) For i = 1 To UBound(rCells) Arr(i) = wks.Shapes.AddConnector(1, rCells(i - 1).Left, rCells(i - 1).Top, rCells(i).Left, rCells(i).Top).Name Next Set DrawLines = wks.Shapes.Range(Arr).Group End If ExitFunc: End Function

2> Code chính của bạn
Ví dụ bạn muốn vẽ các đường thằng đi qua Top, Left của các cell G3, G5, E6, G7, G8, I9, G10, G12, D13, G14

Mã:

Sub Draw() DrawLines [G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14] End Sub

Hàm DrawLines trả về kết quả là 1 Shape, vì thế sau khi vẽ xong, bạn hoàn toàn có thể format nó theo ý mình
Ví dụ:

Mã:

Sub Draw() With DrawLines([G3], [G5], [E6], [G7], [G8], [I9], [G10], [G12], [D13], [G14]) .Name = "Tia sét" .Line.ForeColor.RGB = vbRed .Line.Weight = 3 End With End Sub

Chào anh !
Em co đoạn này để vẽ hình oval, nhưng mà các tọa độ để hình xuất hiện thì không cố định.
Có cách nào xác định toạ độ không vậy
ActiveSheet.Shapes.AddShape(msoShapeOval, 242.25, 30, 74.24, 30).Select

Cảm ơn anh !

Bluestar092011 · 21/1/22

Truongan1996 đã viết:
Chào anh !
Em co đoạn này để vẽ hình oval, nhưng mà các tọa độ để hình xuất hiện thì không cố định.
Có cách nào xác định toạ độ không vậy
ActiveSheet.Shapes.AddShape(msoShapeOval, 242.25, 30, 74.24, 30).Select

Cảm ơn anh !

Thử code này xem có đúng ý chưa.

Mã:

Sub addshapetocell(Rng As Range, W As Double, H As Double)
    Dim clLeft As Double
    Dim clTop As Double
    Dim shpOval As Shape
    clLeft = Rng.Left
    clTop = Rng.Top
    Set shpOval = ActiveSheet.Shapes.AddShape(msoShapeOval, clLeft, clTop, W, H)
End Sub

Public Sub Test()
    addshapetocell Selection, 40, 10
End Sub

Chèn Shape vào bảng tính theo vị trí của cell

phuvacgach

Thành viên chính thức

File đính kèm

ndu96081631

Huyền thoại GPE

phuvacgach

Thành viên chính thức

File đính kèm

ndu96081631

Huyền thoại GPE

phuvacgach

Thành viên chính thức

ndu96081631

Huyền thoại GPE

File đính kèm

phuvacgach

Thành viên chính thức

ndu96081631

Huyền thoại GPE

File đính kèm

Truongan1996

Thành viên mới

Bluestar092011

Thành viên hoạt động

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng