'Tac gia: anhtuan1066
'---------------------------------------------------------------------------------------
' Chú Thích : Tien ich chen Anh
'---------------------------------------------------------------------------------------
Public 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
Dim NameOld As String
Dim FormatPic(), LinkPic()
Dim KichThuoc
Dim TLe As Double
Dim j As Byte, i As Byte
On Error Resume Next
Application.Volatile
Set fso = CreateObject("Scripting.FileSystemObject")
If PicCel Is Nothing Then Set PicCel = Application.ThisCell 'meu ko chon vung chen thi lay o hien tai
PicCel(1, 1).Comment.Delete 'xoa comment
On Error GoTo Thoat
'neu duong dan nhap vao dung thi thuc hien lenh chen anh, nguoc lai thi kiem tra va chinh sua lai duong dan
If fso.FileExists(PicPath) Then GoTo Nex
'khai bao mang duoi dinh dang anh
FormatPic = Array(".JPG", ".JPEG", ".JPE", ".TIFF", ".GIF", ".PNG", ".BMP")
'khai bao duong dan 1: file hien tai, 2: picture
LinkPic = Array(ActiveWorkbook, _
CreateObject("Shell.Application").Namespace(&H27&).Self)
'ten duong dan anh nhap vao
NameOld = UCase(PicPath)
For i = 0 To UBound(FormatPic)
If NameOld Like "*" & FormatPic(i) Then NameOld = Replace(NameOld, FormatPic(i), "") 'xoa dinh dang cu di
Next i
For j = 0 To UBound(LinkPic)
For i = 0 To UBound(FormatPic)
PicPath = LinkPic(j).Path & "\" & NameOld & FormatPic(i) 'thay the duong dan moi va dinh dang moi
If fso.FileExists(PicPath) Then GoTo Nex
Next i
Next j
Nex:
'neu link chinh xac thi chen hinh anh
If fso.FileExists(PicPath) Then
If PicCel(1, 1).MergeCells Then
Set mRng = PicCel(1, 1).MergeArea
If mRng Is Nothing Then Set mRng = PicCel(1, 1)
Else
Set mRng = PicCel
End If
'KichThuoc d c d c
KichThuoc = PicDimensions(PicPath)
'KichThuoc = Mid(KichThuoc, 2, Len(KichThuoc) - 2)
KichThuoc = Split(Replace(KichThuoc & "x" & mRng.Width & "x" & mRng.Height, " ", ""), "x")
TLe = Application.WorksheetFunction.Min(KichThuoc(2) / KichThuoc(0), _
KichThuoc(3) / KichThuoc(1))
With Application.ThisCell
If .Comment Is Nothing Then .AddComment
.Comment.Text vbLf
Set cmt = .Comment
'CommPic = ""
End With
'Set cmt = mRng(1, 1).Comment
cmt.Visible = True
ActiveSheet.PageSetup.PrintComments = xlPrintInPlace
With cmt.Shape
.LockAspectRatio = msoFalse
.Shadow.Visible = msoFalse
.Line.ForeColor.RGB = PicCel.Interior.Color
.AutoShapeType = msoShapeRectangle
.Left = mRng.Left + (mRng.Width - (KichThuoc(0) * TLe)) / 2
.Top = mRng.Top + (mRng.Height - (KichThuoc(1) * TLe)) / 2
.Width = KichThuoc(0) * TLe 'mRng.Width
.Height = KichThuoc(1) * TLe 'mRng.Height
.ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
.ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
.Fill.UserPicture PicPath
End With
Else
Application.ThisCell.Comment.Delete 'nguoc lai xoa hinh di
End If
Thoat:
Set fso = Nothing
Set PicCel = Nothing
Set mRng = Nothing
Set cmt = Nothing
End Function
Function PicDimensions(ByVal FileName As String) 'lay size anh
On Error Resume Next
Dim sName As String, sFolder As String
Dim fso As Object, oShel As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set oShel = CreateObject("Shell.Application")
If fso.FileExists(FileName) Then
sFolder = fso.GetFile(FileName).ParentFolder.Path
sName = fso.GetFile(FileName).Name
With oShel.Namespace("" & sFolder & "")
PicDimensions = .Getdetailsof(.ParseName("" & sName & ""), 31)
End With
End If
PicDimensions = Mid(PicDimensions, 2, Len(PicDimensions) - 2)
End Function
