Giúp sửa code chèn ảnh (1 người xem)

[iloveit]

Tôi tham khảo trên diễn đàn có code của anh Nghĩa Phúc như sau.

Sub InsertPicture()
Dim vFile
vFile = Application.GetOpenFilename("All Pictures, *.bmp;*.jpg;*.jpeg;*.png;*.gif")
If TypeName(vFile) = "String" Then
With ActiveCell
ActiveSheet.Shapes.AddPicture(CStr(vFile), msoFalse, msoTrue, .Left, .Top, .Width, .Height).Placement = xlMoveAndSize
End With
End If
End Sub

Bây giờ tôi muốn khi mình đang đứng ở bất kỳ cell nào đó trong cột D và double click thì sẽ hiện ra 1 cửa sổ để lấy ảnh từ source của máy tính.

Các bước thực hiện tôi mong muốn như sau:
Step 1: Chọn vào ô Cần chèn ảnh (tất nhiên ô này có chỉnh độ rộng trước)
Step 2: double click vào cell hiện hành.
Step 3: Hiện ra 1 cửa sổ để lấy ảnh từ source của máy tính
Step 4: Chọn ảnh, Chọn Insert từ cửa sổ là xong, ảnh sẽ nằm lọt vừa khít trong ô luôn.

Nhờ cách anh chị và các bạn giúp tôi. Cảm ơn.

 

[iloveit]

Ngoài ra còn có code của anh ndu như sau, nhờ mọi người sửa lại giúp cho phù hợp với mong muốn của mình.

Sub InsertPic()
Dim vFile, pic As Picture
vFile = Application.GetOpenFilename("All Pictures, *.bmp; *.jpg; *.jpeg;*.png;*.gif")
If TypeName(vFile) = "String" Then
On Error Resume Next
With ActiveCell
.Parent.Shapes(.Address).Delete
On Error GoTo 0
Set pic = .Parent.Pictures.Insert(CStr(vFile))
pic.ShapeRange.LockAspectRatio = False
pic.Left = .Left: pic.Top = .Top
pic.Width = .Width: pic.Height = .Height
pic.Placement = 1
pic.Name = .Address
End With
End If
End Sub

 

[giaiphap]

Tôi tham khảo trên diễn đàn có code của anh Nghĩa Phúc như sau.

Sub InsertPicture()
Dim vFile
vFile = Application.GetOpenFilename("All Pictures, *.bmp;*.jpg;*.jpeg;*.png;*.gif")
If TypeName(vFile) = "String" Then
With ActiveCell
ActiveSheet.Shapes.AddPicture(CStr(vFile), msoFalse, msoTrue, .Left, .Top, .Width, .Height).Placement = xlMoveAndSize
End With
End If
End Sub

Bây giờ tôi muốn khi mình đang đứng ở bất kỳ cell nào đó trong cột D và double click thì sẽ hiện ra 1 cửa sổ để lấy ảnh từ source của máy tính.

Các bước thực hiện tôi mong muốn như sau:
Step 1: Chọn vào ô Cần chèn ảnh (tất nhiên ô này có chỉnh độ rộng trước)
Step 2: double click vào cell hiện hành.
Step 3: Hiện ra 1 cửa sổ để lấy ảnh từ source của máy tính
Step 4: Chọn ảnh, Chọn Insert từ cửa sổ là xong, ảnh sẽ nằm lọt vừa khít trong ô luôn.

Nhờ cách anh chị và các bạn giúp tôi. Cảm ơn.

Thì bạn sử dụng sự kiện này cho Sheet

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim vFile
vFile = Application.GetOpenFilename("All Pictures, *.bmp;*.jpg;*.jpeg;*.png;*.gif")
If TypeName(vFile) = "String" Then
With ActiveCell
ActiveSheet.Shapes.AddPicture(CStr(vFile), msoFalse, msoTrue, .Left, .Top, .Width, .Height).Placement = xlMoveAndSize
End With
End If
End Sub

 

[tueyennhi]

Bạn đã sử dụng code này của thầy NDU chưa
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
bChk = fso.FileExists(PicPath)
If bChk = False Then
PicPath = ThisWorkbook.Path & "" & PicPath
bChk = fso.FileExists(PicPath)
End If
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
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


Gõ vào cell muốn chèn công thức sau
=CommPic("Cell chứa tên ảnh&".jpg",,99%,99%)