- Khi dùng xlBitmap thì code sẽ convert thành Bitmap file
- Khi dùng xlPicture thì code sẽ convert thành METAFILE
Để ý sẽ thấy Bitmap cho hình nét hơn METAFILE. Bạn hãy chỉnh size của shape và CommandButton to lên, bạn sẽ thấy sự phân biệt càng rõ
----------------
Ngoài ra xin lưu ý rằng: Nếu dùng code này cho ImageList thì nó chỉ chấp nhận BITMAP (không chấp nhận METAFILE) ---> Vì vậy phải truyền tham số vào cho hợp lý (cụ thể cho biến bType = TRUE)
-----------------
Code trên bạn không hiểu cũng không sao! Biết cách dùng là được:
- Với biến đầu vào là bất cứ thứ gì (miễn có thể dùng được .CopyPicture)
- Code sẽ convert đầu vào thành dạng IPictureDisp
- Với kết quả là IPictureDisp, ta có thể Save thành file trên đĩa, có thể đưa vào Image.. vân vân...
vậy thôi
Sau khi xem lại thật kỹ hàm PictureFromObject, tôi có nhận xét thế này:
- Nếu sửa đoạn Target.CopyPicture thành Target.CopyPicture , xlBitmap thì những đoạn IF sau đó trở nên vô nghĩa
Ví dụ:
a> PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE) sẽ luôn cho kết quả = CF_BITMAP
b> If PicType = CF_BITMAP Then sẽ luôn = TRUE
vân... vân...
- Vậy ta nên cho thêm 1 đối số vào hàm trên để người dùng tự quyết định CopyPictue theo kiểu xlBitmap hoặc xlPicture
Hàm được sửa lại như sau:
Mã:
Function PictureFromObject(ByVal Target As Object, [COLOR=#ff0000][B]Optional ByVal bType As Boolean = True[/B][/COLOR]) As IPictureDisp
Dim hPtr As Long, hCopy As Long, PicType As Long
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PicType_BITMAP = 1
Const PicType_ENHMETAFILE = 4
Target.CopyPicture , [B][COLOR=#ff0000]IIf(bType, xlBitmap, xlPicture)[/COLOR][/B]
PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(PicType) <> 0 Then
If OpenClipboard(0) > 0 Then
hPtr = GetClipboardData(PicType)
If PicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
CloseClipboard
If hPtr <> 0 Then
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(PicType = CF_BITMAP, PicType_BITMAP, PicType_ENHMETAFILE)
.hPic = hCopy
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set PictureFromObject = IPic
End If
End If
End If
End Function
Code trong UserForm của viethoai được rút gọn thế này:
Mã:
Private Sub CommandButton1_Click()
Dim IPic As IPictureDisp, shp As Shape
On Error Resume Next
Set shp = Sheet1.Shapes("sh1")
If Not shp Is Nothing Then
[COLOR=#ff0000][B]Set IPic = PictureFromObject(shp)[/B][/COLOR]
Me.CommandButton1.Picture = IPic
Else
MsgBox "Không tìm thay shape nào!"
End If
End Sub
Load Shape lên UserForm trong 2 trường hợp: Set IPic = PictureFromObject(shp)
hoặc Set IPic = PictureFromObject(shp, FALSE)
Rồi so sánh kết quả nhìn thấy trên CommandButton (có khác biệt)
- Khi dùng xlBitmap thì code sẽ convert thành Bitmap file
- Khi dùng xlPicture thì code sẽ convert thành METAFILE
Để ý sẽ thấy Bitmap cho hình nét hơn METAFILE. Bạn hãy chỉnh size của shape và CommandButton to lên, bạn sẽ thấy sự phân biệt càng rõ
----------------
Ngoài ra xin lưu ý rằng: Nếu dùng code này cho ImageList thì nó chỉ chấp nhận BITMAP (không chấp nhận METAFILE) ---> Vì vậy phải truyền tham số vào cho hợp lý (cụ thể cho biến bType = TRUE)
-----------------
Code trên bạn không hiểu cũng không sao! Biết cách dùng là được:
- Với biến đầu vào là bất cứ thứ gì (miễn có thể dùng được .CopyPicture)
- Code sẽ convert đầu vào thành dạng IPictureDisp
- Với kết quả là IPictureDisp, ta có thể Save thành file trên đĩa, có thể đưa vào Image.. vân vân...
vậy thôi
Có một sự cố không hề nhỏ, đó là khi file hình được load lên từ ổ đĩa nào đó, nếu nó có tồn tại thì không sao, nhưng mình xóa file hình đó đi, nó sẽ bị như trong hình.
==> Nó chỉ thực hiện đúng khi và chỉ khi file hình có tồn tại trong ổ đĩa.
Có một sự cố không hề nhỏ, đó là khi file hình được load lên từ ổ đĩa nào đó, nếu nó có tồn tại thì không sao, nhưng mình xóa file hình đó đi, nó sẽ bị như trong hình.
==> Nó chỉ thực hiện đúng khi và chỉ khi file hình có tồn tại trong ổ đĩa.
Ủa! Liên quan gì đến vụ load hình từ ổ cứng nhỉ?
Topic này đang bàn việc load shape có trên bảng tính cơ mà
???
Mà cái vụ tồn tại hay không tồn tại gì đó, sao Nghĩa lại không giải quyết được chứ?
Ủa! Liên quan gì đến vụ load hình từ ổ cứng nhỉ?
Topic này đang bàn việc load shape có trên bảng tính cơ mà
???
Mà cái vụ tồn tại hay không tồn tại gì đó, sao Nghĩa lại không giải quyết được chứ?
Em thử với cái rút thăm vừa rồi, đặt logo trên desktop, load logo lên sheet, chạy form, logo hiển thị OK. Lưu file và Thoát. Xóa logo trên desktop đi, mở file chạy form: Không có hình trong sheet, nhưng có một cái shape với dấu X màu đỏ, có dòng chữ link file này không tồn tại, dĩ nhiên, chạy form cũng không có hình! Vậy mới quái chứ!
Quái hơn là vào sọt rác, restore logo lại, mở form, OK.
Em rất thích cái vụ này bởi khi load file hình lên sheet thì xem như hình đó đã được tồn tại trong file Excel, khi mở form thì theo đó mà nó load lên từ sheet thôi, nhưng nếu load hình lên sheet rồi mà xóa hình ở ổ đĩa thì xem như hình trong sheet của "tan biến" luôn hay đem qua máy khác không có hình đó cũng sống dỡ chết dỡ.
Lại quay lại với VBProject.VBComponents thì em chẳng thích tí nào, bởi khi can thiệp vào đây nó phải bắt check cái Trust Center, rồi file mà có VBA password nó cũng không cho thực hiện!
Nếu cách trên không bị sự cố "mất link" thì hay biết mấy, sau khi load hình xong thì qua máy nào cũng mở ra được vì đã lưu file hình lên sheet rồi.
nhưng nếu load hình lên sheet rồi mà xóa hình ở ổ đĩa thì xem như hình trong sheet của "tan biến" luôn hay đem qua máy khác không có hình đó cũng sống dỡ chết dỡ.
Làm gì có vụ đó ta?
???
Nghĩa thử làm trên file mới xem:
- Load hình từ ổ cứng vào sheet
- Xong, lưu file Excel và đóng lại
- Xóa hình
- Mở file Excel kiểm tra thử xem hình còn không
Theo tôi biết thì trong Word có chức năng load hình theo kiểu link chứ Excel thì làm gì có
Làm gì có vụ đó ta?
???
Nghĩa thử làm trên file mới xem:
- Load hình từ ổ cứng vào sheet
- Xong, lưu file Excel và đóng lại
- Xóa hình
- Mở file Excel kiểm tra thử xem hình còn không
Theo tôi biết thì trong Word có chức năng load hình theo kiểu link chứ Excel thì làm gì có
Rất kỳ lạ nha Thầy, em lấy file này thực hiện trên WinXP, Excel 2003, xóa hình trong ổ đĩa thoái mái không bị gì hết, tuyệt! Cũng với file đó, em thực hiện trên laptop Win7, Excel 2010, tải hình lên, xong, trên form thực hiện load hình thì OK, lưu file lại, thoát, xóa hình, mở file, hình bị "die" trên sheet!
Các bạn thử tải file về và kiểm tra giúp mình xem có bị vấn đề như thế giống như ở máy của mình không nha. Cám ơn.
Rất kỳ lạ nha Thầy, em lấy file này thực hiện trên WinXP, Excel 2003, xóa hình trong ổ đĩa thoái mái không bị gì hết, tuyệt! Cũng với file đó, em thực hiện trên laptop Win7, Excel 2010, tải hình lên, xong, trên form thực hiện load hình thì OK, lưu file lại, thoát, xóa hình, mở file, hình bị "die" trên sheet!
Các bạn thử tải file về và kiểm tra giúp mình xem có bị vấn đề như thế giống như ở máy của mình không nha. Cám ơn.
Private Sub cmdSetting_Click()
On Error Resume Next
Dim PictIns As IPictureDisp, PictExt As Shape
If tbxFilePath = "" Then
MsgBox "Ban phai nhap duong dan", vbInformation + vbOKOnly, "THÔNG BÁO"
tbxFilePath.SetFocus
Else
With Sheet1
.Pictures.Delete
[COLOR=#ff0000].Pictures.Insert(tbxFilePath.Text).Name = "HoangTrongNghia"
Set PictExt = .Shapes("HoangTrongNghia")[/COLOR]
End With
If Not PictExt Is Nothing Then
Set PictIns = PictureFromObject(PictExt)
lblLogo.Picture = PictIns
End If
End If
End Sub
Hãy sửa thành:
Mã:
Private Sub cmdSetting_Click()
On Error Resume Next
Dim PictIns As IPictureDisp, PictExt As Shape
If tbxFilePath = "" Then
MsgBox "Ban phai nhap duong dan", vbInformation + vbOKOnly, "THÔNG BÁO"
tbxFilePath.SetFocus
Else
With Sheet1
.Pictures.Delete
[COLOR=#ff0000] Set PictExt = .Shapes.AddPicture(tbxFilePath.Text, True, True, 200, 200, 200, 200)
PictExt.Name = "HoangTrongNghia"[/COLOR]
End With
If Not PictExt Is Nothing Then
Set PictIns = PictureFromObject(PictExt)
lblLogo.Picture = PictIns
End If
End If
End Sub
Ngoài ra còn 1 chiêu khá đơn giản là SaveAs file thành định dạng XLSM sẽ ngon lành ngay. (cũng đã đến lúc nên khuyên người dùng xài Office 2010 hoặc version cao hơn, ai chưa cài thì.. nghỉ xài chương trình vậy)
-----------------------------------------------------
Ah... mà vấn đề Nghĩa đang hỏi thì liên quan gì đến chủ đề "Load Shap của sheet lên Button..." nhỉ?
Mặc dù nó không liên quan đến Button, nhưng gần như toàn bộ code mà Thầy viết xài chung cho các Controls mà controls đó có thể load picture, vì thế nó mở rộng ra chứ không bị lạc đề ạ.
Mặc dù nó không liên quan đến Button, nhưng gần như toàn bộ code mà Thầy viết xài chung cho các Controls mà controls đó có thể load picture, vì thế nó mở rộng ra chứ không bị lạc đề ạ.
Ý mình nói thật ra vấn đề của Nghĩa không liên quan đến chủ đề của topic. Có thể thí nghiệm:
Mã:
Sub Test()
Dim vFile
vFile = Application.GetOpenFilename("Image Files, *.jpg")
If TypeName(vFile) = "String" Then Sheet1.Pictures.Insert CStr(vFile)
End Sub
Cho code vào 1 file trắng rồi lưu với định dạng XLS và thí nghiệm
Code đơn giản, không đụng gì đến hàm PictureFromObject nhưng nó vẫn bị lỗi. Vậy đó là vấn đề của Picture Object + Version Office, đúng không?
Ý mình nói thật ra vấn đề của Nghĩa không liên quan đến chủ đề của topic. Có thể thí nghiệm:
Mã:
Sub Test()
Dim vFile
vFile = Application.GetOpenFilename("Image Files, *.jpg")
If TypeName(vFile) = "String" Then Sheet1.Pictures.Insert CStr(vFile)
End Sub
Cho code vào 1 file trắng rồi lưu với định dạng XLS và thí nghiệm
Code đơn giản, không đụng gì đến hàm PictureFromObject nhưng nó vẫn bị lỗi. Vậy đó là vấn đề của Picture Object + Version Office, đúng không?
Đúng rồi Thầy ạ! Nó hoàn toàn không phải do hàm tạo ra lỗi đó (thí nghiệm đã cho thấy điều đó).
Từ đó có thể thấy, để file nhẹ đi (theo em), các phiên bản sau của Excel, thay vì Insert "nguyên bản" vào trong sheet, thì nó lại đưa link vào (như web) để hiển thị dạng "thumbnail".
--------------------------------------------------------------------
Nhưng nhận định trên cũng không đúng! Dùng thủ công để Insert hình rồi lưu lại và đóng file, sau đó xóa hình đi, mở file ra, hình vẫn còn!
Từ đó có thể thấy, để file nhẹ đi (theo em), các phiên bản sau của Excel, thay vì Insert "nguyên bản" vào trong sheet, thì nó lại đưa link vào (như web) để hiển thị dạng "thumbnail".
Cái này cũng không đúng nha. Nó chỉ bị lỗi khi file được lưu ở định dạng XLS và mở trên Excel 2010 mà thôi. Nếu lưu theo định dạng XLSM hoặc XLSB (hoặc lưu XLS và mở bằng Excel 2003) lại không có vấn đề gì cả
------------------------
xin chào mọi người, cảm ơn thầy vì hàm PictrurefromObject , nó rất hữu ich và tuyệt vời ạ.
nhưng có một vấn đề, đó là chất lượng ảnh sau khi cho vào form bị giảm đi so với ảnh gốc ở trên sheet ạ, em đã thực hiện cho ảnh vào form, và trong from em có thêm 1 nút để zoom form to lên nếu cần(chỉnh kích thước khung ảnh lớn lên ạ)
và khi đó ảnh bị vỡ, dù ảnh trong sheet có chất lượng cao ạ.
thầy và mọi người có thể giải quyết được vấn đề này không ạ.
vấn đề đã giải quyết rồi ạ, đó là nếu để ảnh dưới dạng xlPicture và copy dạng metafile thì chất lượng ảnh sẽ không bị giảm như bitmap, có zoom lên cũng không sao ạ.
Sau khi xem lại thật kỹ hàm PictureFromObject, tôi có nhận xét thế này:
- Nếu sửa đoạn Target.CopyPicture thành Target.CopyPicture , xlBitmap thì những đoạn IF sau đó trở nên vô nghĩa
Ví dụ:
a> PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE) sẽ luôn cho kết quả = CF_BITMAP
b> If PicType = CF_BITMAP Then sẽ luôn = TRUE
vân... vân...
- Vậy ta nên cho thêm 1 đối số vào hàm trên để người dùng tự quyết định CopyPictue theo kiểu xlBitmap hoặc xlPicture
Hàm được sửa lại như sau:
Mã:
Function PictureFromObject(ByVal Target As Object, [COLOR=#ff0000][B]Optional ByVal bType As Boolean = True[/B][/COLOR]) As IPictureDisp
Dim hPtr As Long, hCopy As Long, PicType As Long
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PicType_BITMAP = 1
Const PicType_ENHMETAFILE = 4
Target.CopyPicture , [B][COLOR=#ff0000]IIf(bType, xlBitmap, xlPicture)[/COLOR][/B]
PicType = IIf(IsClipboardFormatAvailable(CF_BITMAP) <> 0, CF_BITMAP, CF_ENHMETAFILE)
If IsClipboardFormatAvailable(PicType) <> 0 Then
If OpenClipboard(0) > 0 Then
hPtr = GetClipboardData(PicType)
If PicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
CloseClipboard
If hPtr <> 0 Then
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(PicType = CF_BITMAP, PicType_BITMAP, PicType_ENHMETAFILE)
.hPic = hCopy
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set PictureFromObject = IPic
End If
End If
End If
End Function
Code trong UserForm của viethoai được rút gọn thế này:
Mã:
Private Sub CommandButton1_Click()
Dim IPic As IPictureDisp, shp As Shape
On Error Resume Next
Set shp = Sheet1.Shapes("sh1")
If Not shp Is Nothing Then
[COLOR=#ff0000][B]Set IPic = PictureFromObject(shp)[/B][/COLOR]
Me.CommandButton1.Picture = IPic
Else
MsgBox "Không tìm thay shape nào!"
End If
End Sub
Load Shape lên UserForm trong 2 trường hợp: Set IPic = PictureFromObject(shp)
hoặc Set IPic = PictureFromObject(shp, FALSE)
Rồi so sánh kết quả nhìn thấy trên CommandButton (có khác biệt)
Thầy ơi, bài hay quá thầy, em cũng đang có 1 ý định ứng dụng cái này vào file của em.
Mà em mới down file thầy về để chạy thử mà nó báo lỗi như này là sao thầy...
(E cũng mới tập tành vọc mày vọc kia, mong thầy thông cảm nếu có gì sai sót ạ)
Thầy ơi, bài hay quá thầy, em cũng đang có 1 ý định ứng dụng cái này vào file của em.
Mà em mới down file thầy về để chạy thử mà nó báo lỗi như này là sao thầy...
(E cũng mới tập tành vọc mày vọc kia, mong thầy thông cảm nếu có gì sai sót ạ)
Sub RangeShapeToFile(ByVal source As Object, ByVal filename As String)
Dim ext As String
If TypeName(source) <> "Shape" And TypeName(source) <> "Range" Then Exit Sub
ext = LCase(Mid(filename, InStrRev(filename, ".") + 1))
If ext = "bmp" Or ext = "jpg" Or ext = "gif" Then
source.CopyPicture , xlBitmap
ElseIf ext = "png" Then
source.CopyPicture , xlPicture
Else
Exit Sub
End If
With source.Parent.ChartObjects.Add(source.left, source.top, source.Width, source.Height)
.Activate
.Chart.Paste
.Chart.Export filename, ext
.Delete
End With
End Sub
Sub test()
RangeShapeToFile ThisWorkbook.Worksheets("Sheet1").Shapes("Rectangle 1"), "c:\shape.bmp"
RangeShapeToFile ThisWorkbook.Worksheets("Sheet1").Shapes("Rectangle 1"), "c:\shape.jpg"
RangeShapeToFile ThisWorkbook.Worksheets("Sheet1").Shapes("Rectangle 1"), "c:\shape.gif"
RangeShapeToFile ThisWorkbook.Worksheets("Sheet1").Shapes("Picture 2"), "c:\picture.png"
RangeShapeToFile ThisWorkbook.Worksheets("Sheet1").Shapes("Image1"), "c:\image.png"
RangeShapeToFile ThisWorkbook.Worksheets("Sheet1").range("A1:C2"), "c:\range.png"
SavePicture
End Sub
Nếu là Image (Developer -> Insert -> Activex Controls -> Image) thì cũng có thể đơn giản hơn
Mã:
Private Sub UserForm_Initialize()
Dim pic As IPictureDisp
Set pic = ThisWorkbook.Worksheets("Sheet1").OLEObjects("Image1").Object.Picture
' nhap anh vao Image tren Form
Image1.Picture = pic
' hoac ghi tren dia
' SavePicture pic, "c:\image2.bmp"
Set pic = Nothing
End Sub
