Xin code kiểm tra xem 1 ảnh đã tồn tại trong sheets đó chưa.

[Thanhlam2425]

Mọi người cho mình xin 1 đoạn code để kiểm tra xem ảnh đó có tồn tại trong sheets excel đó chưa vậy.VBA nhé.Kiểm tra theo tên ảnh ạ.

 

[Thanhlam2425]

Mọi người cho mình xin 1 đoạn code để kiểm tra xem ảnh đó có tồn tại trong sheets excel đó chưa vậy.VBA nhé.Kiểm tra theo tên ảnh ạ.

Mọi người giúp em với ạ.

 

[Phuocam]

Thử:

Function ShapeExists(sn As String) As Boolean
Dim s As Object
On Error Resume Next
Set s = ActiveSheet.Shapes.Range(Array(sn))
ShapeExists = CBool(Err.Number = 0)
Set s = Nothing
End Function

 

[Thanhlam2425]

Thử:

Function ShapeExists(sn As String) As Boolean
Dim s As Object
On Error Resume Next
Set s = ActiveSheet.Shapes.Range(Array(sn))
ShapeExists = CBool(Err.Number = 0)
Set s = Nothing
End Function

Vâng em cảm ơn anh ạ.Giờ em không ngồi máy nên không kiểm tra được anh ạ.Anh có thể cho en hỏi là anh dùng biến s nhưng không thấy dùng đến là sao ạ.

 

[HeSanbi]

Bạn có thể áp dụng code sau để kiểm tra các Shape
Nếu bạn để AlertCount:=True nếu không tìm thấy Shape thì sẽ thông báo các Shape có trong Trang tính
Nếu tìm thấy thì trả lại các thông số vị trí của Shape

Copy code dưới vào Module bất kì và lưu thành xlsb hoặc xlsm

Sub test_CheckShapes()
  MsgBox CheckShapes("picture 1")
  'MsgBox CheckShapes("picture 1", AlertCount:=True)
  Dim sh As Worksheet, reL&, reT&, reW&, reH&
  Call CheckShapes("picture 1", , reL&, reT&, reW&, reH&, AlertCount:=True)
  MsgBox "Left: " & reL & vbNewLine & _
         "Top: " & reT & vbNewLine & _
         "Width: " & reW & vbNewLine & _
         "Height: " & reH
End Sub
  Function CheckShapes(ByVal ShpName$, Optional WS As Worksheet, _
  Optional ByRef reL&, Optional ByRef reT&, Optional ByRef reW&, Optional ByRef reH&, _
  Optional ByRef AlertCount As Boolean = False) As Boolean
    Dim shape, IsPicture As Boolean, k&, AllShape$
    If WS Is Nothing Then Set WS = ActiveSheet
    For Each shape In WS.Shapes
      If LCase$(shape.Name) = LCase$(ShpName) Then
        reL = shape.Left: reT = shape.Top
        reW = shape.Width: reH = shape.Height
        CheckShapes = True
      End If
      k = k + 1
      AllShape = vbNewLine & AllShape & shape.Name
    Next shape
    If k > 0 And AlertCount Then MsgBox "Có " & k & " Shape trong Trang tính : " & WS.Name & AllShape
  End Function

 

[Thanhlam2425]

Bạn có thể áp dụng code sau để kiểm tra các Shape
Nếu bạn để AlertCount:=True nếu không tìm thấy Shape thì sẽ thông báo các Shape có trong Trang tính
Nếu tìm thấy thì trả lại các thông số vị trí của Shape

Copy code dưới vào Module bất kì và lưu thành xlsb hoặc xlsm

Sub test_CheckShapes()
  MsgBox CheckShapes("picture 1")
  'MsgBox CheckShapes("picture 1", AlertCount:=True)
  Dim sh As Worksheet, reL&, reT&, reW&, reH&
  Call CheckShapes("picture 1", , reL&, reT&, reW&, reH&, AlertCount:=True)
  MsgBox "Left: " & reL & vbNewLine & _
         "Top: " & reT & vbNewLine & _
         "Width: " & reW & vbNewLine & _
         "Height: " & reH
End Sub
  Function CheckShapes(ByVal ShpName$, Optional WS As Worksheet, _
  Optional ByRef reL&, Optional ByRef reT&, Optional ByRef reW&, Optional ByRef reH&, _
  Optional ByRef AlertCount As Boolean = False) As Boolean
    Dim shape, IsPicture As Boolean, k&, AllShape$
    If WS Is Nothing Then Set WS = ActiveSheet
    For Each shape In WS.Shapes
      If LCase$(shape.Name) = LCase$(ShpName) Then
        reL = shape.Left: reT = shape.Top
        reW = shape.Width: reH = shape.Height
        CheckShapes = True
      End If
      k = k + 1
      AllShape = vbNewLine & AllShape & shape.Name
    Next shape
    If k > 0 And AlertCount Then MsgBox "Có " & k & " Shape trong Trang tính : " & WS.Name & AllShape
  End Function

Cảm ơn bạn nhé.Không có câu lệnh nào kiểm tra luôn sự tồn tại của ảnh đó nhỉ.Cái này vẫn phải duyệt qua từng ảnh trong đó.Nếu có tầm 10000 ảnh chắc cũng lâu.Hihi.

 

[HeSanbi]

Cảm ơn bạn nhé.Không có câu lệnh nào kiểm tra luôn sự tồn tại của ảnh đó nhỉ.Cái này vẫn phải duyệt qua từng ảnh trong đó.Nếu có tầm 10000 ảnh chắc cũng lâu.Hihi.

Code phía trên nữa đã làm điều đó rồi.

 

[Thanhlam2425]

Thử:

Function ShapeExists(sn As String) As Boolean
Dim s As Object
On Error Resume Next
Set s = ActiveSheet.Shapes.Range(Array(sn))
ShapeExists = CBool(Err.Number = 0)
Set s = Nothing
End Function

À em hiểu rồi.Cái này dùng bẫy lỗi để xác định có trong sheets không.

 

[Thanhlam2425]

Code phía trên nữa đã làm điều đó rồi.

Bạn ơi bạn có thể xem hộ mình bài này được không ạ.
https://giaiphapexcel.com/diendan/t...c-rồi-gửi-cho-người-khác-vẫn-xem-được.140516/