Shape line

tuhocvba · 22/8/23

Mình có vấn đề như sau.
Tôi cần kiểm tra các đường nào đang nối vào "Rectangle 3" (hình màu đỏ). Tuy nhiên kết quả trả về là :
Shape Elbow Connector 25 is connected to the Rectangle 3
Trong khi quan sát chúng ta thấy đang có 3 đường kẻ nối vào.

Mã:

Sub IdentifyConnectedShapes33()
    Dim ws As Worksheet
    Dim flg1   As Boolean, flg2 As Boolean
   
   
    Dim shape As shape
    Dim rectangle As shape
   
    Dim startX As Double
    Dim startY As Double
    Dim endX As Double
    Dim endY As Double
    Dim s As String
   
    Set ws = ActiveSheet
    Set rectangle = ws.Shapes("Rectangle 3")
   
   
    For Each shape In ws.Shapes
       
        If shape.Type = 1 Or shape.Type = 9 Or shape.Type = 5 Then
           
            If shape.Name <> rectangle.Name Then
               

                startX = shape.Left
                startY = shape.Top
                endX = shape.Left + shape.Width
                endY = shape.Top + shape.Height
               
               
                flg1 = (startX >= rectangle.Left And startX <= rectangle.Left + rectangle.Width) _
                   And (startY >= rectangle.Top And startY <= rectangle.Top + rectangle.Height)
                 
                flg2 = (endX >= rectangle.Left And endX <= rectangle.Left + rectangle.Width) _
                   And (endY >= rectangle.Top And endY <= rectangle.Top + rectangle.Height)
                 
                If flg1 Or flg2 Then
                 
                    Debug.Print "Shape " & shape.Name & " is connected to the " & rectangle.Name
               
                End If
            End If
        End If
    Next shape
End Sub

Bạn cần đăng nhập để thấy hình ảnh

lyly · 23/8/23

Tôi thử thấy elbow13 và elbow14 kết nối không biết còn thiếu gì nữa không ?

Mã:

Sub IdentifyConnectedShapesc()
    Dim ws As Worksheet
    Dim rectangle As shape
    Dim connectedShape As shape
    
    Set ws = ActiveSheet
    Set rectangle = ws.Shapes("Rectangle 3")
    
    For Each connectedShape In ws.Shapes
        If IsConnectableShape(connectedShape) And Not IsSameShape(connectedShape, rectangle) Then
            If AreShapesConnected(connectedShape, rectangle) Then
                MsgBox "Shape " & connectedShape.Name & " is connected to " & rectangle.Name
            End If
        End If
        MsgBox connectedShape.Name
    Next connectedShape
End Sub

Function IsConnectableShape(shape As shape) As Boolean
    IsConnectableShape = shape.Type = msoAutoShape Or shape.Type = msoTextBox
End Function

Function IsSameShape(shape1 As shape, shape2 As shape) As Boolean
    IsSameShape = shape1.Name = shape2.Name
End Function

Function AreShapesConnected(shape As shape, rectangle As shape) As Boolean
    Dim shapeLeft As Double
    Dim shapeTop As Double
    Dim shapeRight As Double
    Dim shapeBottom As Double
    Dim rectLeft As Double
    Dim rectTop As Double
    Dim rectRight As Double
    Dim rectBottom As Double
    
    shapeLeft = shape.Left
    shapeTop = shape.Top
    shapeRight = shape.Left + shape.Width
    shapeBottom = shape.Top + shape.Height
    
    rectLeft = rectangle.Left
    rectTop = rectangle.Top
    rectRight = rectangle.Left + rectangle.Width
    rectBottom = rectangle.Top + rectangle.Height
    
    AreShapesConnected = (shapeRight >= rectLeft And shapeLeft <= rectRight) _
                         And (shapeBottom >= rectTop And shapeTop <= rectBottom)
End Function

tuhocvba · 23/8/23

Code trên của @lyly chỉ ra được Connector: Elbow 14, Connector: Elbow 13 nối vào Rectangle 3. Nhưng chưa chỉ ra được Straight Connector 15 cũng nối vào nó.
cảm ơn @lyly nhé.

tuhocvba · 23/8/23

Sửa xíu code, thì làm được với type9, type1:

Mã:

Sub viduuujj()
    Dim s1 As String, s2 As String
    s1 = "Rectangle 3"
    s2 = "Rectangle 4"
    MsgBox isconnect(s1, s2)
End Sub
Function isconnect(ByVal shpName1 As String, ByVal shpName2 As String) As Boolean
    Dim flg1 As Boolean, flg2 As Boolean
    
    flg1 = IsConnectType1(shpName1, shpName2)
    flg2 = IsConnectType9(shpName1, shpName2)
    
    isconnect = (flg2 Or flg1)
End Function
'Type 1
Function IsConnectType1(ByVal shpName1 As String, ByVal shpName2 As String) As Boolean
    Dim ws As Worksheet
    Dim rectangle1 As shape, rectangle2 As shape
    Dim connectedShape As shape
    
    
    Dim s1  As String, s2 As String
    Dim arr, brr
    Dim Dic As Object
    Dim Key As String
    Dim i   As Long, j As Long
    
    On Error Resume Next
    
    Set ws = ActiveSheet
    Set rectangle1 = ws.Shapes(shpName1)
    Set rectangle2 = ws.Shapes(shpName2)
    
    IsConnectType1 = False
    
    For Each connectedShape In ws.Shapes
        If IsConnectableShape(connectedShape) And Not IsSameShape(connectedShape, rectangle1) Then
            If AreShapesConnected(connectedShape, rectangle1) Then
                s1 = connectedShape.Name & "#@#" & s1
            End If
        End If
        
        If IsConnectableShape(connectedShape) And Not IsSameShape(connectedShape, rectangle2) Then
            If AreShapesConnected(connectedShape, rectangle2) Then
                s2 = connectedShape.Name & "#@#" & s2
            End If
        End If
      
    Next connectedShape
    
    If s1 = "" Or s2 = "" Then
        IsConnectType1 = False
        GoTo thoat
    End If
    
    Set Dic = CreateObject("Scripting.Dictionary")
    arr = Split(s1, "#@#", , vbTextCompare)
    brr = Split(s2, "#@#", , vbTextCompare)
    
    For i = LBound(arr) To UBound(arr) Step 1
        Key = MyCstr(arr(i))
        If Key <> "" Then
            If Not Dic.Exists(Key) Then
                Dic.Item(Key) = i
            End If
        End If
    Next i
    
    For i = LBound(brr) To UBound(brr) Step 1
        Key = MyCstr(brr(i))
        If Dic.Exists(Key) Then
            IsConnectType1 = True
            Set Dic = Nothing
            GoTo thoat
        End If
    Next i
thoat:
    On Error GoTo 0
End Function

Function MyCstr(ByVal s As Variant) As String
    If IsNull(s) = True Or IsEmpty(s) = True Then
        MyCstr = ""
    Else
        MyCstr = CStr(s)
    End If
End Function

Function IsConnectableShape(shape As shape) As Boolean
    IsConnectableShape = shape.Type = msoAutoShape Or shape.Type = msoTextBox
End Function

Function IsSameShape(shape1 As shape, shape2 As shape) As Boolean
    IsSameShape = shape1.Name = shape2.Name
End Function

Function AreShapesConnected(shape As shape, rectangle As shape) As Boolean
    Dim shapeLeft As Double
    Dim shapeTop As Double
    Dim shapeRight As Double
    Dim shapeBottom As Double
    Dim rectLeft As Double
    Dim rectTop As Double
    Dim rectRight As Double
    Dim rectBottom As Double
    
    shapeLeft = shape.Left
    shapeTop = shape.Top
    shapeRight = shape.Left + shape.Width
    shapeBottom = shape.Top + shape.Height
    
    rectLeft = rectangle.Left
    rectTop = rectangle.Top
    rectRight = rectangle.Left + rectangle.Width
    rectBottom = rectangle.Top + rectangle.Height
    
    AreShapesConnected = (shapeRight >= rectLeft And shapeLeft <= rectRight) _
                         And (shapeBottom >= rectTop And shapeTop <= rectBottom)
End Function

'=====================================================
'Type 9
Function IsConnectType9(ByVal shpName1 As String, ByVal shpName2 As String) As Boolean
    Dim ws As Worksheet
    Set ws = ActiveSheet ' Thay th? "Sheet1" b?ng ten c?a sheet b?n ?ang lam vi?c
    
    Dim shape1 As shape
    Dim shape2 As shape
    Dim connector As shape
    Dim flg1 As Boolean, flg2 As Boolean
    
    On Error Resume Next
    For Each connector In ws.Shapes
        If connector.Type = msoLine Then
            
            If connector.ConnectorFormat.Type = msoConnectorStraight Or connector.ConnectorFormat.Type = msoConnectorElbow Then
                Set shape1 = connector.ConnectorFormat.BeginConnectedShape
                Set shape2 = connector.ConnectorFormat.EndConnectedShape
                
                If Not shape1 Is Nothing And Not shape2 Is Nothing Then
                    flg1 = (shape1.Name = shpName1) And (shape2.Name = shpName2)
                    flg2 = (shape2.Name = shpName1) And (shape2.Name = shpName2)
                    If flg1 = True Or flg2 = True Then
                        IsConnectType9 = True
                    Else
                        IsConnectType9 = False
                    End If
                End If
            End If
        End If
    Next connector
    On Error GoTo 0
End Function

Euler · 25/8/23

Đối với line có type = 1. Ta phân tích một chút.

Bạn cần đăng nhập để thấy đính kèm

Hình bao ngoài cùng là trang tính Excel.
Đường màu đỏ là đường line shape mà ta đang phân tích. Rõ ràng ta chỉ muốn quan tâm tới hai điểm đầu mút (chấm đỏ), thế nhưng trong thực tế ta chỉ có 4 thông số là Left, Right, Top, Bottom.
Để dễ hình dung, hãy tưởng tượng có một hình chữ nhật bao khít lấy cái đường line shape này.
Thông số Left, Top có thể lấy trực tiếp.
Thông số Right lấy trung gian qua Left và width.
Thông số Bottom lấy trung gian qua Top và Height.

Tình huống 1: Đường line shape kết nối với rectangle ở phía bên phải (right side). Ta có hai tình huống như sau:

Bạn cần đăng nhập để thấy đính kèm

Ngay cả trong trường hợp này thì cũng chia ra làm hai trường hợp con.
flg1 = True khi: Điểm đầu mút của line shape phải nằm bên trong rectangle. Điều đó có nghĩa là: shapeLeft >= rectLeft.

Bạn cần đăng nhập để thấy đính kèm

Và shapeLeft <= rectRight.

Bạn cần đăng nhập để thấy đính kèm

Và: rectTop <= shapeTop <= rectBottom

Bạn cần đăng nhập để thấy đính kèm

Tổng kết lại:

Mã:

flg1 = (shapeLeft >= rectLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)

flg2 = True khi: Xét về hoành độ thì cũng tương tự như trên, ta phải có (shapeLeft >= rectLeft) And (shapeLeft <= rectRight), tuy nhiên khi xét về tung độ thì có chút khác. rectTop <= shapeBottom < = rectBottom

Bạn cần đăng nhập để thấy đính kèm

Tổng kết lại:

Mã:

flg2 = (shapeLeft >= rectLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom < = rectBottom)

Euler · 25/8/23

Tình huống 2: Đường line shape kết nối với rectangle ở phía bên trái (lleft side). Ta có hai tình huống như sau:

Bạn cần đăng nhập để thấy đính kèm

flg3 = True khi: Điểm đầu mút bên phải của line shape nằm trong rectangle.
Tức là rectLeft < = shapeRight <= rectRight

Bạn cần đăng nhập để thấy đính kèm

Và: rectTop <= shapeTop <= rectBottom

Bạn cần đăng nhập để thấy đính kèm

Tóm lại là:

Mã:

flg3 = (rectLeft < = shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)

flg4 = True khi: Điểm đầu mút bên phải của line shape nằm trong rectangle.
Về điểm này thì cũng giống với trường hợp ở trên, tức là rectLeft < = shapeRight <= rectRight

Bạn cần đăng nhập để thấy đính kèm

Tuy nhiên khi xét về tung độ thì có chút khác biệt: rectTop < = shapeBottom <= rectBottom

Bạn cần đăng nhập để thấy đính kèm

Tóm lại là:

Mã:

flg4 = (rectLeft < = shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom <= rectBottom)

Như vậy có thể thấy code của @lyly phải chăng nên viết lại cho chuẩn là:

Mã:

Function AreShapesConnected(shape As shape, rectangle As shape) As Boolean
    Dim shapeLeft As Double
    Dim shapeTop As Double
    Dim shapeRight As Double
    Dim shapeBottom As Double
    Dim rectLeft As Double
    Dim rectTop As Double
    Dim rectRight As Double
    Dim rectBottom As Double
    Dim flg1 As Boolean, flg2 As Boolean, flg3 As Boolean, flg4 As Boolean
    
    shapeLeft = shape.Left
    shapeTop = shape.Top
    shapeRight = shape.Left + shape.Width
    shapeBottom = shape.Top + shape.Height
    
    rectLeft = rectangle.Left
    rectTop = rectangle.Top
    rectRight = rectangle.Left + rectangle.Width
    rectBottom = rectangle.Top + rectangle.Height
    
    flg1 = (shapeLeft >= rectLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)
    flg2 = (shapeLeft >= rectLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom <= rectBottom)
    
    flg3 = (rectLeft <= shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)
    flg4 = (rectLeft <= shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom <= rectBottom)
    
    AreShapesConnected = flg1 Or flg2 Or flg3 Or flg4
End Function

giaiphapvba · 26/8/23

Các diễn giải của Euler về mặt hình học là đúng, nhưng chỉ với góc quay của line shape là 0 độ hoặc 180 độ.

Bạn cần đăng nhập để thấy đính kèm

Mã:

Angle = shp.Rotation

Trong trường hợp góc quay của line shape là 90 độ hoặc 270 độ, các diễn giải hình học ở trên không còn phù hợp.

Bạn cần đăng nhập để thấy đính kèm

Hình trên cho thấy line shape đang được quay góc 270 độ. Và chiều cao là 55.48 và chiều rộng là 9.6 (???)

Mã:

Sub tuhocvba2608()
    Dim ws As Worksheet
    Dim shp As shape
    Dim elbowX As Double, elbowY As Double
   

    Set ws = ThisWorkbook.Worksheets("Sheet1")
   

    Set shp = ws.Shapes("Elbow Connector 13")
   

    Angle = shp.Rotation
   

    MsgBox Angle & ":" & shp.Height & "," & shp.Width
End Sub

Tức là trong tưởng tượng hình học của chúng ta đang có sự sai khác.
Hãy chú ý hình trên một lần nữa, tôi sẽ kiểm tra bằng code khác và nhận được thông tin như sau:

Mã:

------------
Rectangle 9
Elbow Connector 13
shapeTop:76.5962982177734 , rectTop:36.5
shapeBottom:132.083148956299 , rectBottom:99.5
shapeRight:98.0831508636475 , rectRight:121
shapeLeft:88.4037017822266 , rectLeft:10
------------

Đường line shape có thông tin shapeTop đáng ra phải sát với rectBottom nhưng chúng ta thấy có sự chênh lệch khá lớn.
shapeTop:76.5962982177734
rectBottom:99.5

vbano1 · 27/8/23

Nào, bây giờ ta sẽ xem xét các thông số của shape line thay đổi như thế nào nếu nó được quay góc 270 độ.

Bạn cần đăng nhập để thấy đính kèm

Để thuận tiện trong quá trình lấy thông tin các shape, kịch bản là nếu tôi select vào một shape nào đó rồi chạy code thì nó sẽ cho tôi thông tin.

Mã:

Sub Lay thong tin()
    Dim shp As shape
    On Error Resume Next
    ' Set shape la hinh dang duoc select
    Set shp = Selection.ShapeRange.Item(1)
    On Error GoTo 0
    
    
'    Angle = shp.Rotation
'    MsgBox Angle
    Debug.Print shp.Name & " Top:" & shp.Top
    Debug.Print shp.Name & " Left:" & shp.Left
    Debug.Print shp.Name & " Height:" & shp.Height
    Debug.Print shp.Name & " width:" & shp.Width
End Sub

Tôi được các thông tin như sau:

Mã:

Rectangle 1           
    Top    29   
    Left    48   
    Height    59   
    width    191.5

Và:

Mã:

Elbow Connector 19       
        
    Top    54.25
    Left    177.5
    Height    96.5
    width    29

Trong trường hợp này Elbow Connector 19 đang bị quay 270 độ, có thể thấy thông tin trên không giúp chúng ta tính toán chuẩn được.
Cụ thể Top của Elbow Connector 19 không có lý nào lại chỉ là 54.25 trong khi nó nằm thấp hơn Rectangle 1, trong khi bottom của Rectangle 1 là:

Mã:

Rectangle 1_Top + Rectangle 1_Height = 29 + 59 = 88

Thông tin của Elbow Connector 19 ở trên thực chất là thông tin trước khi nó bị quay 270 độ.

Bạn cần đăng nhập để thấy đính kèm

Xác định hoành độ của điểm tâm G:

Bạn cần đăng nhập để thấy đính kèm

Mã:

Elbow Connector 19_Left + Elbow Connector 19_width/2 = 177.5 + 29/2 = 192

Bạn cần đăng nhập để thấy đính kèm

Như vậy Elbow Connector 19_Left hiện tại (sau khi quay 270 độ là):

Bạn cần đăng nhập để thấy đính kèm

Kết quả bây giờ là:

Mã:

Elbow Connector 19_Left = 143.75

Kết quả này phù hợp nếu nhìn lại hình vẽ ban đầu, điểm nối vào chính giữa cạnh đáy của Rectangle 1. Ta sẽ sử dụng Rectangle 1 để tính toán lại và sử dụng kết quả này để kiểm chứng kết quả ở phía trên.

Bạn cần đăng nhập để thấy đính kèm

Để ngắn gọn ta gọi Elbow Connector 19 là shp. Công thức tính left của nó được xây dựng lại là:

Mã:

G_left = (shp.width/2) + shp.Left
shp_newLeft = G_left -(shp.Height/2)'=143.75
shp_newRight = shp_newLeft + shp.Height

Để xác định Top và Bottom của Elbow Connector 19, ta cũng phải tính lại qua trung gian điểm G.

Bạn cần đăng nhập để thấy đính kèm

Tóm lại công thức là Top mới là:

Mã:

G_Top = (shp.Height/2) + shp.Top' = 96.5/2 + 54.25 = 48.25 + 54.25 = 102.5
shp_newTop = G_Top -(shp.Width/2)'=102.5 - 29/2 = 102.5 - 14.5 = 88
shp_newBottom = shp_newTop + shp.width '=88 + 29 = 117

Kết quả này có thể kiểm chứng bằng Rectangle 1:

Mã:

Rectangle 1_Top + Rectangle 1_Height = 29 + 59 = 88

vbano1 · 27/8/23

Xác nhận công thức trên vẫn đúng trong trường hợp: Angle = 90.
Từ đó có thể thấy rằng, code của @lyly và @Euler có thể cải thiện thêm để kiểm tra tiếp xúc ở đáy hoặc cạnh trên cùng.

Mã:

Sub vidu()
    Dim ws  As Worksheet
    Dim shp     As shape, rec As shape
    Dim Angle   As Double
    
    Dim shp_newLeft As Double, shp_newRight     As Double
    Dim shp_newTop  As Double, shp_newBottom    As Double
    

    Set ws = ActiveSheet
  

    Set shp = ws.Shapes("Elbow Connector 19")
    Set rec = ws.Shapes("Rectangle 2")

    MsgBox AreShapesConnected(shp, rec)

    
End Sub
Function AreShapesConnected(shape As shape, rectangle As shape) As Boolean
    Dim shapeLeft As Double
    Dim shapeTop As Double
    Dim shapeRight As Double
    Dim shapeBottom As Double
    Dim rectLeft As Double
    Dim rectTop As Double
    Dim rectRight As Double
    Dim rectBottom As Double
    
    Dim Angle   As Double
    
    Dim flg1    As Boolean, flg2 As Boolean, flg3 As Boolean, flg4 As Boolean, _
        flg5    As Boolean, flg6 As Boolean
    
    Angle = shape.Rotation
    
    If Angle = 270 Or Angle = 90 Then
        Dim G_Top   As Double, G_left As Double
        
        G_Top = (shape.Height / 2) + shape.Top
        shapeTop = G_Top - (shape.Width / 2)
        shapeBottom = shapeTop + shape.Width
        
        G_left = (shape.Width / 2) + shape.Left
        shapeLeft = G_left - (shape.Height / 2)
        shapeRight = shapeLeft + shape.Height
    Else
    
        shapeLeft = shape.Left
        shapeTop = shape.Top
        shapeRight = shape.Left + shape.Width
        shapeBottom = shape.Top + shape.Height
    
    End If
    
    
    rectLeft = rectangle.Left
    rectTop = rectangle.Top
    rectRight = rectangle.Left + rectangle.Width
    rectBottom = rectangle.Top + rectangle.Height
    
    flg1 = (shapeLeft >= rectLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)
    flg2 = (shapeLeft >= rectLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom <= rectBottom)
    
    flg3 = (rectLeft <= shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)
    flg4 = (rectLeft <= shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom <= rectBottom)
    
    flg5 = (rectLeft <= shapeLeft) And (shapeLeft <= rectRight) And (rectTop <= shapeTop) And (shapeTop <= rectBottom)
    flg6 = (rectLeft <= shapeRight) And (shapeRight <= rectRight) And (rectTop <= shapeBottom) And (shapeBottom <= rectBottom)
    
    AreShapesConnected = flg1 Or flg2 Or flg3 Or flg4 Or flg5 Or flg6
End Function

Bạn cần đăng nhập để thấy đính kèm

tuhocvba · 27/8/23

Các code trên đều gặp phải một vấn đề, đó là hai shape trùng tên.
shp.Name không phải là thông tin duy nhất giống như biển số xe, nó có thể trùng nhau.

Bạn cần đăng nhập để thấy đính kèm

Cho nên bước tiền xử lý đánh lại tên theo tôi là cần thiết.

Mã:

Sub ResetShapeName()
    Dim ws As Worksheet
    Dim shp As shape
    Dim uniqueI&
    Dim s$
    Dim myver&

    Set ws = ActiveSheet ' sheet lam viec
    uniqueID = 1 ' Bat dau danh so ID tu 1
   
    For Each shp In ws.Shapes
        s = shp.Name
        myver = FindVerShapeName(s)
        uniqueID = uniqueID + 1
        If myver > 9 Then
            myver = -1
        End If
        s = Left(s, 3) & "_" & CStr(myver + 1) & "_THVBA_" & uniqueID
        shp.Name = s
       
    Next shp
End Sub
Function FindVerShapeName(ByVal inputStr As String) As Long

    Dim regexPattern As String
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    

    

    regexPattern = "_(\d+)_THVBA_"
    

    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Global = False
        .IgnoreCase = True
        .Pattern = regexPattern
    End With
    

    If regex.test(inputStr) Then
        Set matches = regex.Execute(inputStr)
        If matches.Count > 0 Then
            For Each match In matches
                FindVerShapeName = CLng(match.SubMatches(0))
                Exit Function
            Next match
        End If
    End If
End Function

giaiphapvba · 1/9/23

Chỉ cần đổi dòng code :

Mã:

If connector.Type = msoLine Then

thành:

Mã:

If connector.Type = 9 Or connector.Type = 1 Then

thì sẽ xét được hai trường hợp Type = 1 và Type = 9.

Mã:

Sub vidu()
    Dim s1$, s2$
    s1 = "Rectangle 1"
    s2 = "Rectangle 2"
    
    MsgBox IsConnectType9And1(s1, s2)
End Sub
Function IsConnectType9And1(ByVal shpName1 As String, ByVal shpName2 As String) As Boolean
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim shape1 As Shape
    Dim shape2 As Shape
    Dim connector As Shape
    Dim flg1 As Boolean, flg2 As Boolean
    
    On Error Resume Next
    For Each connector In ws.Shapes
        'Dim d
        'd = connector.Type
        If connector.Type = 9 Or connector.Type = 1 Then
            
            If connector.ConnectorFormat.Type = msoConnectorStraight Or connector.ConnectorFormat.Type = msoConnectorElbow Then
                Set shape1 = connector.ConnectorFormat.BeginConnectedShape
                Set shape2 = connector.ConnectorFormat.EndConnectedShape
                
                If Not shape1 Is Nothing And Not shape2 Is Nothing Then
                    flg1 = (shape1.Name = shpName1) And (shape2.Name = shpName2)
                    flg2 = (shape2.Name = shpName1) And (shape1.Name = shpName2)
                    If flg1 = True Or flg2 = True Then
                        IsConnectType9And1 = True
                        'Debug.Print d
                        Exit Function
                    Else
                        IsConnectType9And1 = False
                    End If
                End If
            End If
        End If
    Next connector
    On Error GoTo 0
End Function

Bạn cần đăng nhập để thấy đính kèm

Shape line

tuhocvba

Administrator

Đính kèm

lyly

Nghiện THVBA

tuhocvba

Administrator

tuhocvba

Administrator

Euler

Administrator

Euler

Administrator

giaiphapvba

Administrator

vbano1

SMod

vbano1

SMod

tuhocvba

Administrator

giaiphapvba

Administrator