Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
