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
