Closed tieuquyngok1995 closed 3 years ago
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
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
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