Lỗi kích thước ảnh trên thẻ học sinh (1 người xem)

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
  Dim Shape As Shape, ScreenUpdating As Boolean
  Dim I   As Long
  If Target.Address = "$BA$1" Then
    ScreenUpdating = Application.ScreenUpdating
    Application.ScreenUpdating = False
    With Target.Parent
      For Each Shape In .Shapes
        With Shape
          If .Type <> msoFormControl Then .Delete
        End With
      Next Shape
      
      For I = 6 To 66 Step 15
        AddPictureToRange .Range("C" & I), ThisWorkbook.Path & "\Anh\" & .Range("C" & I).Value & ".JPG"
        AddPictureToRange .Range("AB" & I), ThisWorkbook.Path & "\Anh\" & .Range("AB" & I).Value & ".JPG"
      Next I
    End With
    Application.ScreenUpdating = ScreenUpdating
  End If
End Sub

Function CommPic(ByVal PicPath As String, Optional ByVal PicCel As Range, _
                Optional ByVal ScaleWidth As Single = 1, _
                Optional ByVal ScaleHeight As Single = 1) As String
  Dim mRng As Range, cmt As Comment, fso As Object, bChk As Boolean
  On Error Resume Next
  Application.Volatile
  Set fso = CreateObject("Scripting.FileSystemObject")
  If PicCel Is Nothing Then Set PicCel = Application.ThisCell
  PicCel(1, 1).Comment.Delete
  If Left(PicPath, 7) = "http://" Then
    bChk = URLExists(PicPath)
  Else
[COLOR=#ff0000]Tam = PicPath
  Dim FormatPic
  FormatPic = Array(".JPG", ".JPE", ".GIF", ".PNG", ".BMP")
  For i = 0 To UBound(FormatPic)
    bChk = fso.FileExists(PicPath)
    If bChk = False Then
      PicPath = ThisWorkbook.Path & "\" & Tam & FormatPic(i)
      bChk = fso.FileExists(PicPath)
      If bChk Then GoTo Nex
    End If
    Next i
If bChk = False Then
  For i = 0 To UBound(FormatPic)
    bChk = fso.FileExists(PicPath)
    If bChk = False Then
        PicPath = "C:\Users\" & Environ("Username") & "\Pictures\" & Tam & FormatPic(i)
      bChk = fso.FileExists(PicPath)
      If bChk Then GoTo Nex
    End If
    Next i
End If
Nex:[/COLOR]
  End If
  If bChk Then
    If PicCel(1, 1).Comment Is Nothing Then PicCel(1, 1).AddComment
    PicCel(1, 1).Comment.text vbLf
    Set mRng = PicCel(1, 1).MergeArea
    If mRng Is Nothing Then Set mRng = PicCel(1, 1)
    Set cmt = mRng(1, 1).Comment
    cmt.Visible = True
    With cmt.Shape
      .LockAspectRatio = msoFalse
      .Placement = xlMoveAndSize
      .Shadow.Visible = msoFalse
      .Line.ForeColor.RGB = PicCel.Interior.Color
      .AutoShapeType = msoShapeRectangle
      .Left = mRng.Left: .Top = mRng.Top
      .Width = mRng.Width: .Height = mRng.Height
      .ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
      .ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
      .Fill.UserPicture PicPath
    End With
  End If
      Calculate
End Function
Private Function URLExists(ByVal URL As String) As Boolean
  Application.Volatile
  On Error Resume Next
  If Left(UCase(URL), 7) <> "HTTP://" Then URL = "http://" & URL
  With CreateObject("MSXML2.XMLHTTP")
    .Open "HEAD", URL, False: .send
    URLExists = .Status = 200
  End With
End Function