4

[tieuquyngok1995]

Private Sub ShapeInfo() Dim shp As Shape Dim strText As String Set shp = ActiveSheet.Shapes(1) With shp strText = "Name: " & .Name & vbCrLf & "Text: " & .TextFrame.Characters.Text & vbCrLf & "Left: " & .Left & vbCrLf & "Top: " & .Top & vbCrLf & "Width: " & .Width & vbCrLf & "Height: " & .Height & vbCrLf & "Visible: " & IIf(.Fill.Visible, "True", "False") & vbCrLf & "Fore Color: " & .Fill.ForeColor.RGB & vbCrLf & "Transparency: " & Format(.Fill.Transparency, "0%") & vbCrLf & "Border visible: " & IIf(.Line.Visible, "True", "False") & vbCrLf & "Type: " & GetType(.Type) If .Type = msoAutoShape Then strText = strText & " (" & GetAutoShapeType(.AutoShapeType) & ")" End If End With MsgBox strText, vbInformation End Sub

Function GetType(shpType As MsoShapeType) As String Select Case shpType Case 1 GetType = "AutoShape" Case 2 GetType = "Callout" Case 3 GetType = "Chart" Case 4 GetType = "Comment" Case 5 GetType = "FreeForm" Case 6 GetType = "Group" Case 7 GetType = "Embedded OLE Object" Case 8 GetType = "Form Control" Case 9 GetType = "Line" Case 10 GetType = "Linked OLE Object" Case 11 GetType = "Linked Picture" Case 12 GetType = "OLE Control" Case 13 GetType = "Picture" Case Else GetType = "Other" End Select End Function

Function GetAutoShapeType(shpType As MsoAutoShapeType) As String Select Case shpType Case 1 GetAutoShapeType = "Rectangle" Case 2 GetAutoShapeType = "Parallelogram" Case 3 GetAutoShapeType = "Trapezoid" Case 4 GetAutoShapeType = "Diamond" Case 5 GetAutoShapeType = "Rounded Rectangle" Case 6 GetAutoShapeType = "Octagon" Case 7 GetAutoShapeType = "Isosceles Triangle" Case 8 GetAutoShapeType = "Right Triangle" Case 9 GetAutoShapeType = "Oval" Case 10 GetAutoShapeType = "Hexagon" Case 11 GetAutoShapeType = "Cross" Case 12 GetAutoShapeType = "Regular Pentagon" Case 13 GetAutoShapeType = "Can" Case Else GetAutoShapeType = "Other" End Select End Function

[tieuquyngok1995]

Public Sub ShapeInfo() Dim x& With Sheets("sheet1") For x = 1 To .Shapes.Count Sheets("sheet2").Cells(x + 1, 1).Value = .Shapes(x).Name

        Sheets("sheet2").Cells(x + 1, 2).Value = .Shapes(x).Left
        Sheets("sheet2").Cells(x + 1, 3).Value = .Shapes(x).Top

        Sheets("sheet2").Cells(x + 1, 4).Value = .Shapes(x).Height
        Sheets("sheet2").Cells(x + 1, 5).Value = .Shapes(x).Width

        Sheets("sheet2").Cells(x + 1, 6).Value = .Shapes(x).Top + .Shapes(x).Height
        Sheets("sheet2").Cells(x + 1, 7).Value = .Shapes(x).Left + .Shapes(x).Width
    Next
End With

End Sub

[tieuquyngok1995]

Public Sub ShapeInfo() On Error Resume Next Dim arr() As String Dim index As Integer

Dim leftImg As Integer Dim rightImg As Integer Dim topImg As Integer Dim bottomImg As Integer

Dim leftSh As Integer Dim rightSh As Integer Dim topSh As Integer Dim bottomSh As Integer

With Sheets("sheet1") ReDim arr(.Shapes.Count) For i = 1 To .Shapes.Count If GetType(.Shapes(i).Type) = "Picture" Then leftImg = .Shapes(i).left rightImg = .Shapes(i).left + .Shapes(i).Width topImg = .Shapes(i).Top bottomImg = .Shapes(i).Top + .Shapes(i).Height

        If Not IsEmpty(arr) And i <> 1 And UBound(arr) > 0 Then
            .Shapes.Range(arr).Select
            Selection.Group
        End If

        ReDim arr(.Shapes.Count)
        index = 0
        arr(index) = .Shapes(i).Name

        index = index + 1
    ElseIf GetType(.Shapes(i).Type) = "AutoShape" Then
        leftSh = .Shapes(i).left
        rightSh = .Shapes(i).left + .Shapes(i).Width
        topSh = .Shapes(i).Top
        bottomSh = .Shapes(i).Top + .Shapes(i).Height

        If (leftImg <= leftSh) And (rightImg >= rightSh) And (topImg <= topSh) And (bottomImg >= bottomSh) Then
            arr(index) = .Shapes(i).Name
            index = index + 1
        Else
            If (leftImg > leftSh And leftImg - leftSh < 15) Then
                .Shapes(i).left = leftImg
                leftSh = .Shapes(i).left
            End If

            If (topImg > topSh And topImg - topSh < 15) Then
                .Shapes(i).Top = topImg
                topSh = .Shapes(i).Top
            End If

            rightSh = .Shapes(i).left + .Shapes(i).Width
            bottomSh = .Shapes(i).Top + .Shapes(i).Height
            If (leftImg <= leftSh) And (rightImg >= rightSh) And (topImg <= topSh) And (bottomImg >= bottomSh) Then
                arr(index) = .Shapes(i).Name
                index = index + 1
            End If
        End If
    End If
Next

    If Not IsEmpty(arr) And i <> 1 And UBound(arr) > 0 Then
        .Shapes.Range(arr).Select
        Selection.Group
    End If

End With

End Sub

Private Function GetType(shpType As MsoShapeType) As String Select Case shpType Case 1 GetType = "AutoShape" Case 2 GetType = "Callout" Case 3 GetType = "Chart" Case 4 GetType = "Comment" Case 5 GetType = "FreeForm" Case 6 GetType = "Group" Case 7 GetType = "Embedded OLE Object" Case 8 GetType = "Form Control" Case 9 GetType = "Line" Case 10 GetType = "Linked OLE Object" Case 11 GetType = "Linked Picture" Case 12 GetType = "OLE Control" Case 13 GetType = "Picture" Case Else GetType = "Other" End Select End Function