Load Shape của Sheet lên Button của Form (1 người xem)

viehoai · 3/12/12

Để load hình ảnh của file (.bmp) lên button của form tôi dùng code

Mã:

Private Sub UserForm_Initialize()
  Me.CommandButton1.Picture = LoadPicture("C:\hinh.bmp")
End Sub

Vậy xin hỏi các anh chị với sự kiện trên code nào để load Shape có tên Sh1 ở Sheet1 lên CommandButton1
Xin cảm ơn các anh chị

ndu96081631 · 3/12/12

viehoai đã viết:
Để load hình ảnh của file (.bmp) lên button của form tôi dùng code

Mã:

Private Sub UserForm_Initialize() Me.CommandButton1.Picture = LoadPicture("C:\hinh.bmp") End Sub

Vậy xin hỏi các anh chị với sự kiện trên code nào để load Shape có tên Sh1 ở Sheet1 lên CommandButton1
Xin cảm ơn các anh chị

Việc đầu tiên là phải lưu shape thành 1 file trên ổ cứng
1> Code trong module

PHP:

Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
 
Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
End Type
     
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

PHP:

Function PictureFromObject(Target As Object) As IPictureDisp
  Dim hPtr As Long, PicType As Long, hCopy 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
  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

2> Code cho CommandButton:

PHP:

Private Sub CommandButton1_Click()
  Dim Pic As String, shp As Shape
  On Error Resume Next
  Set shp = Sheet1.Shapes("sh1") ''<--- Xác định shape trên bảng tính
  If Not shp Is Nothing Then
    With CreateObject("Scripting.FileSystemObject")
      Pic = "C:\" & .GetTempName & ".bmp" ''<---- đặt tên shape 1 cách ngẫu nhiên
      SavePicture PictureFromObject(shp), Pic ''<--- Save shape thành picture
      Me.CommandButton1.Picture = LoadPicture(Pic)
      .DeleteFile Pic
    End With
  Else
    MsgBox "Không tìm thay shape nào!"
  End If
End Sub

viehoai · 3/12/12

ndu96081631 đã viết:
Việc đầu tiên là phải lưu shape thành 1 file trên ổ cứng

Không ngờ việc tưởng chừng đơn giản phải đi 1 vòng như thế phức tạp thật
Em cảm ơn rất nhiều, cũng biết thêm cách lưu Shape thành file *.bmp

ndu96081631 · 3/12/12

viehoai đã viết:
Không ngờ việc tưởng chừng đơn giản phải đi 1 vòng như thế phức tạp thật
Em cảm ơn rất nhiều, cũng biết thêm cách lưu Shape thành file *.bmp

Tôi đã tìm hiểu và phát hiện ra 1 cách còn đơn giản hơn
- Đầu tiên tải file Clipboard.RAR dưới đây về, giải nén, được file clipboard.dll
- Copy file clipboard.dll cho vào thư mục C:\Windows\System32
- Xong đăng ký file dll này bằng cách: Start\Run, gõ lệnh: regsvr32 clipboard.dll rồi Enter. Nếu thấy thông báo đăng ký thành công thì có thể tiếp tục công đoạn dưới
----------------------------------
- Khởi động file Excel của bạn, cho code dưới đây vào 1 Module

PHP:

Function PictureFromObject(Target As Object) As IPictureDisp
  On Error Resume Next
  If Not Target Is Nothing Then
    Target.CopyPicture
    Set PictureFromObject = CreateObject("clipbrd.clipboard").GetData(14)
  End If
End Function

- Code cho CommandButton như cũ

Bạn test giúp tôi nhé
(Hình như máy nào có cài VB6 thì file clipboard.dll đã có sẵn thì phải)

siwtom · 3/12/12

viehoai đã viết:
Không ngờ việc tưởng chừng đơn giản phải đi 1 vòng như thế phức tạp thật
Em cảm ơn rất nhiều, cũng biết thêm cách lưu Shape thành file *.bmp

Nếu làm như ndu thì cũng chả phải ghi lên đĩa rồi đọc từ đĩa:

Mã:

Private Sub UserForm_Initialize()
    Me.CommandButton1.Picture = PictureFromObject(Sheet1.Shapes("sh1"))
End Sub

----------------
Nếu cái Shape kia là Image - thẻ Developer --> Insert --> ActiveX Controls --> Image thì cũng chả cần Shape.CopyPicture vào Clipboard rồi lại đọc ra từ Clipboard làm gì.
Module:

Mã:

Function GetPictureObject(ByVal Image As String, Optional ByVal loadOpt As Long = 0, Optional obj As Object = Nothing) As IPictureDisp
'   loadOpt = 0 --> image là đường dẫn tới tập tin ảnh trên đĩa,
'   loadOpt = 1 --> image là index của ảnh trong ImageList và obj là ImageList
'   loadOpt <> 0 và loadOpt <> 1--> image là tên của ảnh trên Sheet và obj là tên Sheet đó
Dim pic As MSForms.Image
Dim objOLE As OLEObject
    On Error GoTo error_
    
    If loadOpt = 0 Then
'        đọc từ đĩa
        Set GetPictureObject = LoadPicture(Image)
    ElseIf loadOpt = 1 Then
'        đọc từ ImageList
        If Not obj Is Nothing Then
            Set GetPictureObject = obj.ListImages(CLng(Image)).Picture
        End If
    Else
'        lay từ Sheet
        If Not obj Is Nothing Then
            Set objOLE = obj.OLEObjects(Image)
            If objOLE.progID = "Forms.Image.1" Then
                Set pic = objOLE.Object
                Set GetPictureObject = pic.Picture
            End If
            Set objOLE = Nothing
            Set pic = Nothing
        End If
    End If
error_:
End Function

UserForm:

Mã:

Private Sub UserForm_Initialize()
    Me.CommandButton1.Picture = GetPictureObject("sh1", 2, Sheet1)
End Sub

Dùng hàm GetPictureObject có thể nhập ảnh từ tập tin trên đĩa, từ ImageList và từ Image trên Sheet.

Về cái DLL của ndu thì cũng dễ hiểu thôi. "Người ta" cũng phải đọc từ Clipboard như mình. Mình không "đọc" thì phải dùng DLL của người ta để đọc, nhưng đi đâu cũng phải mang DLL theo rồi copy, đăng ký vào system. Mình tự làm thì chả phải mang theo cái gì cả.

À mà SavePicture thì cũng chỉ save thành BMP mà thôi. Không save được thành JPG cho dù trước đó nhập vào Shape ảnh JPG.

ndu96081631 · 3/12/12

siwtom đã viết:
Nếu làm như ndu thì cũng chả phải ghi lên đĩa rồi đọc từ đĩa:

Mã:

Private Sub UserForm_Initialize() Me.CommandButton1.Picture = PictureFromObject(Sheet1.Shapes("sh1")) End Sub

Cái này bây giờ mới biết
Em cứ tưởng nó chỉ lấy được Picture từ file trên đĩa thôi chứ

siwtom đã viết:
À mà SavePicture thì cũng chỉ save thành BMP mà thôi. Không save được thành JPG cho dù trước đó nhập vào Shape ảnh JPG.

Ủa, em test code của em ở trên, SavePicture thành file JPG cũng đâu có vấn đề gì đâu anh?

siwtom · 3/12/12

ndu96081631 đã viết:
Cái này bây giờ mới biết
Em cứ tưởng nó chỉ lấy được Picture từ file trên đĩa thôi chứ

Ủa, em test code của em ở trên, SavePicture thành file JPG cũng đâu có vấn đề gì đâu anh?

Nói chính xác thì:
Nếu trong Picture có Metafile thì sau khi SavePicture Tuấn có MetaFile cho dù Tuấn chọn tên ghi là bla.emf, bla.bmp, bla.jpg, bla.gif, bla.txt, bla.avi, bla (không có "đuôi")
Nếu trước đó nhập vào Picture JPG, GIF, BMP thì sau khi SavePicture Tuấn có BMP cho dù Tuấn chọn tên ghi là bla.emf, bla.bmp, bla.jpg, bla.gif, bla.txt, bla.avi, bla (không có "đuôi")
------------
Tuấn có thể đổi tên bla.avi thành bla.txt nhưng lõi của nó vẫn là AVI chứ không phải là TXT. Do lõi thực không phải là TXT nên Tuấn không thể click để mở xem AVI. Vì mặc định thì system sẽ dùng notepad để mở TXT. Khi Tuấn click bla.txt thì system sẽ dùng notepad để mở bla.txt, vì sytem đâu có kiểm tra "lõi" của tập tin. Nhưng notepad không thể mở được bla.txt vì lõi của nó thực ra là dạng AVI chứ không phải TXT. Nếu Tuấn chuột phải rồi chọn "Open with" rồi chọn Media Player thì nó mở phim cho TUấn xem vì "lõi" đúng là AVI, cái "đuôi" TXT kia không quan trọng.
"Đuôi" chỉ là để nhận biết dạng tập tin, nhưng là kiểu: Tôi tin là anh có đuôi thế thật. Lõi mới là quan trọng. Lõi dạng nào thì tập tin có dạng thế thật. Nếu tôi "dùng" tên "Nguyễn Thị Diễm My" thì "người ta tưởng tôi là con gái nhưng khi "lâm trận" thì "lõi" thế nào nó lòi ra ngay.
------------
Tuấn dùng SavePicture có thể nhập tên: bla.bmp, bla.jpg, bla.gif, thậm chí bla.TXT hay bla (không có "đuôi") thì Tuấn sẽ có trên đĩa bla.bmp, bla.jpg, bla.gif, thậm chí bla.TXT hay bla, SavePicture chấp nhận bất cứ tên nào. Nhưng lõi luôn là BMP.
Tuấn có thể mở tập tin đã ghi, vd. bla.txt, bla bằng Paint (vd. mở Paint --> File --> Open --> chọn All Files --> duyệt tới bla.txt hoặc bla). Tuấn có thể mở bla.txt, bla bằng HexEditor thì Tuấn thấy 2 bai đầu là 42 và 4D - "BM". "BM" là signature của tập tin BMP. Nếu Tuấn mở tập tin JPG thì Tuấn sẽ có ở dòng đầu "JFIF". Phần lớn các định dạng đều có signature để nhận biết. Tập tin RAR thì chắc 3 bai đầu là "Rar".
Mà Tuấn có thể mở tập tin mà Tuấn ghi là bla.jpg (dùng SavePicture) bằng Paint rồi ghi lại thành hic.jpg. Khi mở bla.jpg bằng HexEditor thì Tuấn thấy "BM" còn khi mở hic.jpg thì Tuấn có "JFIF". Tức hic.jpg đúng là JPG còn bla.jpg chỉ là tên trá hình thôi còn "đồ" là BMP.

ndu96081631 · 3/12/12

siwtom đã viết:
Nói chính xác thì:
Nếu trong Picture có Metafile thì sau khi SavePicture Tuấn có MetaFile cho dù Tuấn chọn tên ghi là bla.emf, bla.bmp, bla.jpg, bla.gif, bla.txt, bla.avi, bla (không có "đuôi")
Nếu trước đó nhập vào Picture JPG, GIF, BMP thì sau khi SavePicture Tuấn có BMP cho dù Tuấn chọn tên ghi là bla.emf, bla.bmp, bla.jpg, bla.gif, bla.txt, bla.avi, bla (không có "đuôi")
.

Nhân việc anh nói về MetaFile, em hỏi thêm:
- Trong clipbrd.clipboard Object (clipboard.dll) có phương thức GetData(Format as ClipboardConstants)
- ClipboardConstants có vbCFMetafile = 3 và vbCFEMetafile = 14
Em không biết 2 thằng em vbCFMetafile và vbCFEMetafile có gì khác nhau? Vì em test cả 2 thấy đều ra kết quả (nói chung là em không phân biệt được)
--------------------
Thật lòng mà nói: Code toàn là thu thập các nơi + mò mẫm nên nhiều thứ còn ngu ngơ lắm anh à

siwtom · 3/12/12

ndu96081631 đã viết:
Nhân việc anh nói về MetaFile, em hỏi thêm:
- Trong clipbrd.clipboard Object (clipboard.dll) có phương thức GetData(Format as ClipboardConstants)
- ClipboardConstants có vbCFMetafile = 3 và vbCFEMetafile = 14
Em không biết 2 thằng em vbCFMetafile và vbCFEMetafile có gì khác nhau? Vì em test cả 2 thấy đều ra kết quả (nói chung là em không phân biệt được)
--------------------
Thật lòng mà nói: Code toàn là thu thập các nơi + mò mẫm nên nhiều thứ còn ngu ngơ lắm anh à

Trong Windows thì có các hằng số:
CF_ENHMETAFILE = 14 - vbCFEMetafile - có E
CF_METAFILEPICT = 3 - vbCFMetafile - không có E
---------------
Có 2 loại metafile:
1. Ảnh "mua_xuan.wmf" - Windows Metafile Format
2. Ảnh "mua_xua.emf" - Enhanced Metafile Format (thường gặp)
--------------
Khi trong cliipboard có Format = 3 thì có nghĩa là có Windows Metafile Format, nếu có Format = 14 thì có nghĩa là có Enhanced Metafile Format
-----------
Trong Clipboard có thể có đồng thời nhiều Format. Vd. ta copy text trong Excel thì trong clipboard có thể có OEM text (format = 7), text (format = 1), unicode text (format = 13) và sau khi kiểm tra và tùy vào nhu cầu ta có thể đọc ra OEM text, text hoặc unicode text.
Khi ta mở trang web và copy cả trang hoặc một đoạn thì trong clipboard cũng có nhiều format mà chắc chắn 1 trong số đó là "HTML Format".
-------------
Tuấn mở help của tôi hoặc cái đã tải về và xem mục "Set(Get)ClipboardData". Tất nhiên trong clipboard còn có nhiều format hơn là được liệt kê trong help. Ví dụ có format "HTML Format" - vd. khi ta copy vùng trong Excel thì trong clipboard có đồng thời: Bitmap (BMP), WMF, EMF, Richedit format, unicode format, text format, HTML format (có nhiều format nên sau khi copy nếu ta mở WORD thì trong menu "Paste Special" ta có nhiều lựa chọn là vì thế). Tuấn còn có thể tạo 1 cấu trúc dữ liệu rồi copy dữ liệu vào clipboard để rồi sau đó đọc ra. Tất nhiên trước khi copy vào clipboard thì phảii đăng ký format của mình - RegisterClipboardFormat. Và tất nhiên "người khác" cũng có thể đọc ra dữ liệu của Tuấn nhưng do không biết cấu trúc dữ liệu như thế nào nên có được 1 chuỗi bai" thì cũng vô ích.

ndu96081631 · 4/12/12

Còn 1 vấn đề nữa em muốn hỏi:
- Code ở bài 5 của anh chỉ là load image từ file, image list hoặc image control mà thôi
- Đặt trường hợp không dùng đến clipboard.dll, em rất muốn biết anh sẽ viết code để convert shape thành IPictureDisp như thế nào? Hay là phải dùng đến code dài thòng lòng (API) như ở bài 2
- Có cách nào đơn giản hóa code nữa không? Em chỉ quan tâm đến trường hợp object là 1 shape trên bảng tính, còn các trường hợp khác (từ file, image list, image control...) em không quan tâm

siwtom · 4/12/12

ndu96081631 đã viết:
Còn 1 vấn đề nữa em muốn hỏi:
- Code ở bài 5 của anh chỉ là load image từ file, image list hoặc image control mà thôi
- Đặt trường hợp không dùng đến clipboard.dll, em rất muốn biết anh sẽ viết code để convert shape thành IPictureDisp như thế nào? Hay là phải dùng đến code dài thòng lòng (API) như ở bài 2
- Có cách nào đơn giản hóa code nữa không? Em chỉ quan tâm đến trường hợp object là 1 shape trên bảng tính, còn các trường hợp khác (từ file, image list, image control...) em không quan tâm

Nếu tôi không lầm thì không thể đọc được IPictureDisp.
Shape có muôn vàn loại. Đặt xuống sheet 1 đối tượng OLE như Image ta có shape. Đặt Picture (Insert --> Picture) ta cũng có shape. Đặt Oval (Insert --> Shape), Button, Drop Down, List Box, Check Box, Label xuống sheet cũng có shape.
Trong trường hợp những đối tượng kể trên, trừ Image, làm gì có IPictureDisp để mà "lấy". Chỉ có Image là OLE object với thuộc tính Picture.
Vậy nếu không là Image thì tôi cũng sẽ viết code như PictureFromObject ở bài #2. Chính vì thế tôi viết rõ ở bài #5: Nếu cái Shape kia là Image

ndu96081631 · 5/12/12

Em lại hơi tham vọng tí khi có ý định muốn load Shape vào Image list
Có điều sau khi convert shape thành IPictureDisp thì thằng Image List nó không chấp nhận loại này (hình như nó chỉ khoái Bitmap chứ không ưa Metafile)
Xin anh siwtom cho ý kiến giúp em về vấn đề này với
(Cứ có cảm giác chỉ còn 1 bước nữa là lên tới mây, vậy mà lại tuột xuống vực mất rồi ---> Rất bực!)

ndu96081631 · 5/12/12

ndu96081631 đã viết:
Em lại hơi tham vọng tí khi có ý định muốn load Shape vào Image list
Có điều sau khi convert shape thành IPictureDisp thì thằng Image List nó không chấp nhận loại này (hình như nó chỉ khoái Bitmap chứ không ưa Metafile)
Xin anh siwtom cho ý kiến giúp em về vấn đề này với
(Cứ có cảm giác chỉ còn 1 bước nữa là lên tới mây, vậy mà lại tuột xuống vực mất rồi ---> Rất bực!)

Ôi... thôi em phát hiện ra rồi ---> Tất cả là do thằng Format mà ra. Thay vì GetData(14) ta sửa thành GetData(8)
Ở đây em dùng clipboard.dll, còn nếu vẫn dùng các hàm API như bài 2 thì em chưa biết phải sửa lại thế nào nữa. Anh siwtom suy nghĩ giúp em vấn đề này với (dù sao vẫn khoái tự viết hơn là dùng file dll của người khác)
----------------
Xin đính kem file dưới đây file Image Combo ----> Các bạn tải về, giải nén và test giúp nhé

siwtom · 5/12/12

ndu96081631 đã viết:
Ôi... thôi em phát hiện ra rồi ---> Tất cả là do thằng Format mà ra. Thay vì GetData(14) ta sửa thành GetData(8)
Ở đây em dùng clipboard.dll, còn nếu vẫn dùng các hàm API như bài 2 thì em chưa biết phải sửa lại thế nào nữa. Anh siwtom suy nghĩ giúp em vấn đề này với (dù sao vẫn khoái tự viết hơn là dùng file dll của người khác)

Thì Bitmap ImageList nó cũng chấp nhận chứ.
Vậy thì code trong bài #2 là được rồi còn gì.
8 tức DIB - device-independent bitmap
-----------
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const CF_DIB = 8
...
Nhưng lấy CF_BITMAP = 2 là được rồi.

ndu96081631 · 5/12/12

siwtom đã viết:
Thì Bitmap ImageList nó cũng chấp nhận chứ.
Vậy thì code trong bài #2 là được rồi còn gì.
8 tức DIB - device-independent bitmap
-----------
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const CF_DIB = 8
...
Nhưng lấy CF_BITMAP = 2 là được rồi.

Sao em test hàm ở bài 2 mà chẳng thấy ăn thua gì, nó cứ báo lỗi Invalid Picture
Em gửi nguyên file, anh xem giúp em với
(vì không hiểu nên "quậy" lung tung, hên thì trúng...)

ndu96081631 · 5/12/12

ndu96081631 đã viết:
Sao em test hàm ở bài 2 mà chẳng thấy ăn thua gì, nó cứ báo lỗi Invalid Picture
Em gửi nguyên file, anh xem giúp em với
(vì không hiểu nên "quậy" lung tung, hên thì trúng...)

Ôi... cha Bill lại xui xẻo để mình "vọc".. trúng nữa rồi
Chỉ cần sửa:
Target.CopyPicture
Thành:
Target.CopyPicture xlScreen, xlBitmap
là xong!
hoặc vầy cũng được:
Target.CopyPicture , xlBitmap
(ăn tiền chổ xlBitmap ấy, mặc định không ghi gì thì nó là xlPicture)
Tự "vọc" mà nó "ra" 1 phát, đúng là sướớớớớớớng hơn cưới được vợ bốn...
Ẹc... Ẹc...
Bài này ứng dụng cho các bạn TRA CỨU THÉP HÌNH thì quá OK luôn
----------------------------
Các bạn có tải file dưới đây về, nếu test thấy OK cũng nhớ phản hồi cho mình biết với nhé!
Cảm ơn!

siwtom · 5/12/12

ndu96081631 đã viết:
Ôi... cha Bill lại xui xẻo để mình "vọc".. trúng nữa rồi
Chỉ cần sửa:
Target.CopyPicture
Thành:
Target.CopyPicture xlScreen, xlBitmap
là xong!
hoặc vầy cũng được:
Target.CopyPicture , xlBitmap
(ăn tiền chổ xlBitmap ấy, mặc định không ghi gì thì nó là xlPicture)
Tự "vọc" mà nó "ra" 1 phát, đúng là sướớớớớớớng hơn cưới được vợ bốn

Sướng mà hét dài thế thì chắc là cực sướng đây.

viehoai · 9/12/12

Xin lỗi các anh chị, từ khi nhận được kết quả bài 2 của anh ndu96081631 em đột xuất đi Gia Lai nay mới về cũng chưa kịp test hết các bài các anh chị

ndu96081631 · 10/12/12

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)

viehoai · 10/12/12

ndu96081631 đã viết:
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)

Em vẫn chưa thấy sự khác biệt. Xin sư phụ nói rõ hơn

Thực sự với code trên em chưa hiểu nổi, phải nghiên cứu tiếp thôi
Em cảm ơn rất nhiều

ndu96081631 · 10/12/12

viehoai đã viết:
Em vẫn chưa thấy sự khác biệt. Xin sư phụ nói rõ hơn
Thực sự với code trên em chưa hiểu nổi, phải nghiên cứu tiếp thôi
Em cảm ơn rất nhiều

- 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

Hoàng Trọng Nghĩa · 23/1/14

ndu96081631 đã viết:
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)

Bài này hay quá Thầy ơi, hôm nay em mới đọc được! Hay quá chỉ có chép về và nghiên cứu xem mình sẽ ứng dụng gì với hàm này đây!

SẼ NHANH CHÓNG CÓ MỘT ỨNG DỤNG XÀI CHO HÀM PictureFromObject NÀY!

Hoàng Trọng Nghĩa · 25/1/14

ndu96081631 đã viế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.

ndu96081631 · 25/1/14

Hoàng Trọng Nghĩa đã viết:
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ứ?

Hoàng Trọng Nghĩa · 25/1/14

ndu96081631 đã viết:
Ủ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.

Hoàng Trọng Nghĩa · 26/1/14

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.

ndu96081631 · 27/1/14

Hoàng Trọng Nghĩa đã viết:
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ó

Hoàng Trọng Nghĩa · 27/1/14

ndu96081631 đã viết:
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.

ndu96081631 · 28/1/14

Hoàng Trọng Nghĩa đã viết:
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.

Code cũ:

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].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ỉ?

Hoàng Trọng Nghĩa · 28/1/14

ndu96081631 đã viết:
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 đề ạ.

Cám ơn Thầy rất nhiều.

ndu96081631 · 28/1/14

Hoàng Trọng Nghĩa đã viết:
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 đề ạ.

Cám ơn Thầy rất nhiều.

Ý 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?

Hoàng Trọng Nghĩa · 28/1/14

ndu96081631 đã viết:
Ý 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!

ndu96081631 · 29/1/14

Hoàng Trọng Nghĩa đã viết:
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ả
------------------------

Hoàng Trọng Nghĩa đã viết:
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!

Thủ công và tự động đôi khi có sự khác biệt. Lấy ví dụ: Việc chèn 1 CommandButton bằng code và bằng tay sẽ có sự khác nhau đấy

タイン · 7/9/18

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 ạ.

タイン · 7/9/18

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 ạ.

FungoChan79 · 13/11/18

ndu96081631 đã viết:
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 ạ)

batman1 · 14/11/18

FungoChan79 đã viế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 ạ)

View attachment 207604

Nếu muốn ghi ra đĩa thì cũng có thể dùng code ngắn gọn sau.

Ghi vùng (Range) hoặc shape (Insert -> Shapes, Insert -> Picture, Developer -> Insert -> Activex Controls -> Image) vào đĩa. Chấp nhân ghi với định dạng BMP, JPG, GIF, PNG.

RangeShapeToFile là code tổng quát.

Mã:

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 là Image (Developer -> Insert -> Activex Controls -> Image) thì cũng có thể đơn giả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

Load Shape của Sheet lên Button của Form (1 người xem)

Người dùng đang xem chủ đề này

Thành viên gắn bó

File đính kèm

Huyền thoại GPE

File đính kèm

Thành viên gắn bó

Huyền thoại GPE

File đính kèm

Thành viên gắn bó

File đính kèm

Huyền thoại GPE

Thành viên gắn bó

Huyền thoại GPE

Thành viên gắn bó

Huyền thoại GPE

Thành viên gắn bó

Huyền thoại GPE

Huyền thoại GPE

File đính kèm

Thành viên gắn bó

Huyền thoại GPE

File đính kèm

Huyền thoại GPE

File đính kèm

Thành viên gắn bó

Thành viên gắn bó

Huyền thoại GPE

File đính kèm

Thành viên gắn bó

Huyền thoại GPE

Chuyên gia GPE

Chuyên gia GPE

File đính kèm

Huyền thoại GPE

Chuyên gia GPE

Chuyên gia GPE

Huyền thoại GPE

Chuyên gia GPE

File đính kèm

Huyền thoại GPE

Chuyên gia GPE

Huyền thoại GPE

Chuyên gia GPE

Huyền thoại GPE

Thành viên mới

Thành viên mới

Thành viên mới

Thành viên gạo cội

Thời gian đếm ngược.