Mutants Men
Thành viên thường trực
- Tham gia
- 30/12/15
- Bài viết
- 394
- Được thích
- 266
Điều chỉnh code khi load hình vào 1 cell (code của thầy ndu)
Chào mọi người. mình nghịch ngợm viết lại code để chèn ảnh từ máy tính vào excel nhưng dài quá.
mong mọi người giúp mình tối ưu cho nó ngắn lại
cho mình hỏi sao mình để dòng code này .Placement = xlMoveAndSize khi kéo ô rộng ra thì ảnh không kéo theo được mà nó vẫn đơ 1 chỗ như cũ.
cho mình hỏi thêm. khi chèn ảnh như thế. code viết thế nào để kiểm tra ảnh có tồn tại hay không.
1 vấn đề nữa là nếu hàm nằm tại sheet1 khi chọn sheet2 nhấn f9 thì ảnh lại chèn ở sheet2. làm thế nào cho nó chèn đúng sheet có công thức được
sử dụng:
=InsertPic(<Link Ảnh>, <ô cần chèn>,<tỷ lệ Scale chiều rộng>,<tỷ lệ Scale chiều cao>)
vd:
=InsertPic(1) => chèn ảnh có tên 1.*** từ thư mục chứa file excel, nếu không có thì tìm ảnh tại thư mục Picture
=InsertPic("1.jpg") => nếu không có file ảnh .jpg mà có .png thì vẫn chèn được ảnh .png
+ <ô cần chèn> có thể bỏ trống, mặc định là ô chứa công thức
+ <tỷ lệ Scale > từ 0->1, mặc định 1
------------------------------------------
thao khảo và chỉnh sửa lại từ code chèn ảnh bằng ghi chú của thầy ndu
Chào mọi người. mình nghịch ngợm viết lại code để chèn ảnh từ máy tính vào excel nhưng dài quá.
mong mọi người giúp mình tối ưu cho nó ngắn lại
cho mình hỏi sao mình để dòng code này .Placement = xlMoveAndSize khi kéo ô rộng ra thì ảnh không kéo theo được mà nó vẫn đơ 1 chỗ như cũ.
cho mình hỏi thêm. khi chèn ảnh như thế. code viết thế nào để kiểm tra ảnh có tồn tại hay không.
1 vấn đề nữa là nếu hàm nằm tại sheet1 khi chọn sheet2 nhấn f9 thì ảnh lại chèn ở sheet2. làm thế nào cho nó chèn đúng sheet có công thức được
Mã:
Function InsertPic(ByVal PicPath As String, _
Optional ByVal PicCel As Range, _
Optional ByVal ScaleWidth As Single = 1, _
Optional ByVal ScaleHeight As Single = 1) As String
On Error Resume Next
Dim fso As Object
Dim NamePic As String, NameOld As String
Dim i As Byte, j As Byte
Dim FormatPic(), LinkPic()
Application.Volatile
If PicCel Is Nothing Then Set PicCel = Application.ThisCell 'ô chèn anh?
Set PicCel = PicCel(1, 1).MergeArea
NamePic = "PictureIn" & PicCel.Address(0, 0) 'tên anh?
Set fso = CreateObject("Scripting.FileSystemObject")
'neu link dung thi chen luon
If fso.FileExists(PicPath) Then GoTo ChenAnh
'nguoc lai kiem tra link
FormatPic = Array(".JPG", ".JPEG", ".JPE", ".TIFF", ".GIF", ".PNG", ".BMP")
LinkPic = Array(ActiveWorkbook, CreateObject("Shell.Application").Namespace(&H27&).Self)
NameOld = UCase(PicPath)
For j = 0 To UBound(LinkPic)
For i = 0 To UBound(FormatPic)
NameOld = Replace(NameOld, FormatPic(i), "") 'xoa dinh dang cu di
Next i
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 ChenAnh
Next i
Next j
GoTo Thoat
ChenAnh:
ActiveSheet.Shapes.Range(NamePic).Delete 'xóa anh? cu~
ActiveSheet.Pictures.Insert(PicPath).ShapeRange.Name = NamePic 'chen anh
With ActiveSheet.Shapes.Range(NamePic) 'chinh anh
.LockAspectRatio = msoFalse: [COLOR=#0000ff][B].Placement = xlMoveAndSize[/B][/COLOR]
.Left = PicCel.Left + 0.0001: .Top = PicCel.Top + 0.0001
.Width = PicCel.Width - 0.0002: .Height = PicCel.Height - 0.0002
.ScaleWidth ScaleWidth, msoFalse, msoScaleFromMiddle
.ScaleHeight ScaleHeight, msoFalse, msoScaleFromMiddle
End With
InsertPic = "-"
GoTo endd
Thoat:
InsertPic = ""
endd:
Set PicCel = Nothing
Set fso = Nothing
End Function=InsertPic(<Link Ảnh>, <ô cần chèn>,<tỷ lệ Scale chiều rộng>,<tỷ lệ Scale chiều cao>)
vd:
=InsertPic(1) => chèn ảnh có tên 1.*** từ thư mục chứa file excel, nếu không có thì tìm ảnh tại thư mục Picture
=InsertPic("1.jpg") => nếu không có file ảnh .jpg mà có .png thì vẫn chèn được ảnh .png
+ <ô cần chèn> có thể bỏ trống, mặc định là ô chứa công thức
+ <tỷ lệ Scale > từ 0->1, mặc định 1
------------------------------------------
thao khảo và chỉnh sửa lại từ code chèn ảnh bằng ghi chú của thầy ndu
Lần chỉnh sửa cuối:
