Load hình ảnh từ excel lên form trong VBA

giang140387

Thành viên mới
Tham gia ngày
2 Tháng mười hai 2013
Bài viết
21
Được thích
0
Điểm
363
Tuổi
33
Mình có 1 file quản lý thiết bị trong công ty có các cột cơ bản như file đính kèm. Mình muốn show ID của máy ra 1 listbox rồi khi chọn 1 ID sẽ xuất hiện chi tiếc của thiết bị dưới dạng form mình đã design có kèm theo hình ảnh của thiết bị. Vì file của cty bảo mật nên mình chỉ cho thông tin mang tính chất minh họa. Nhờ các bác làm giúp mình với nha.
Xin chân thành cảm ơn }}}}}
 

File đính kèm

Lần chỉnh sửa cuối:

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,337
Được thích
52,767
Điểm
11,910
Mình có 1 file quản lý thiết bị trong công ty có các cột cơ bản như file đính kèm. Mình muốn show ID của máy ra 1 listbox rồi khi chọn 1 ID sẽ xuất hiện chi tiếc của thiết bị dưới dạng form mình đã design có kèm theo hình ảnh của thiết bị. Vì file của cty bảo mật nên mình chỉ cho thông tin mang tính chất minh họa. Nhờ các bác làm giúp mình với nha.
Xin chân thành cảm ơn }}}}}
Điều đầu tiên bạn cần làm là sửa tên hình cho trùng với ID
Tiếp theo, mời xem qua topic này:
http://www.giaiphapexcel.com/forum/showthread.php?74484-Load-Shape-của-Sheet-lên-Button-của-Form/page2
Cuối cùng, xem ứng dụng trong file
Code trong UserForm chỉ có bao nhiêu đây thôi:
Mã:
Dim aSrc As Variant
Private Sub ListBox1_Click()
  Dim PicName As String, pic As Picture, IPic As IPictureDisp
  Dim lR As Long
  On Error Resume Next
  lR = ListBox1.ListIndex
  PicName = Me.ListBox1.List(lR, 0)
  Set pic = Sheet1.Pictures(PicName)
  Set IPic = PictureFromObject(pic, False)
  Image1.Picture = IPic
  TextBox1.Text = aSrc(lR + 1, 2)
  TextBox2.Text = aSrc(lR + 1, 3)
  TextBox3.Text = Format(aSrc(lR + 1, 4), "dd-MMM-yy")
  TextBox4.Text = Format(aSrc(lR + 1, 5), "dd-MMM-yy")
End Sub
Private Sub UserForm_Initialize()
  On Error Resume Next
  aSrc = Sheet1.Range("B2:F12").Value
  ListBox1.List = aSrc
  ListBox1.MultiSelect = fmMultiSelectSingle
  Image1.PictureSizeMode = fmPictureSizeModeStretch
End Sub
Private Sub CommandButton2_Click()
  Unload Me
End Sub
Đương nhiên phải có Module chứa hàm PictureFromObject. Hàm này bạn không cần quan tâm, chỉ cần biết áp dụng là được
 

File đính kèm

chipiu3001

Thành viên chính thức
Tham gia ngày
22 Tháng tám 2015
Bài viết
70
Được thích
11
Điểm
170
Tuổi
32
Điều đầu tiên bạn cần làm là sửa tên hình cho trùng với ID
Tiếp theo, mời xem qua topic này:
http://www.giaiphapexcel.com/forum/showthread.php?74484-Load-Shape-của-Sheet-lên-Button-của-Form/page2
Cuối cùng, xem ứng dụng trong file
Code trong UserForm chỉ có bao nhiêu đây thôi:
Mã:
Dim aSrc As Variant
Private Sub ListBox1_Click()
  Dim PicName As String, pic As Picture, IPic As IPictureDisp
  Dim lR As Long
  On Error Resume Next
  lR = ListBox1.ListIndex
  PicName = Me.ListBox1.List(lR, 0)
  Set pic = Sheet1.Pictures(PicName)
  Set IPic = PictureFromObject(pic, False)
  Image1.Picture = IPic
  TextBox1.Text = aSrc(lR + 1, 2)
  TextBox2.Text = aSrc(lR + 1, 3)
  TextBox3.Text = Format(aSrc(lR + 1, 4), "dd-MMM-yy")
  TextBox4.Text = Format(aSrc(lR + 1, 5), "dd-MMM-yy")
End Sub
Private Sub UserForm_Initialize()
  On Error Resume Next
  aSrc = Sheet1.Range("B2:F12").Value
  ListBox1.List = aSrc
  ListBox1.MultiSelect = fmMultiSelectSingle
  Image1.PictureSizeMode = fmPictureSizeModeStretch
End Sub
Private Sub CommandButton2_Click()
  Unload Me
End Sub
Đương nhiên phải có Module chứa hàm PictureFromObject. Hàm này bạn không cần quan tâm, chỉ cần biết áp dụng là được
Anh Ndu96081631 ơi
Em đã làm được như bác hướng dẫn. Nhưng số lượng ảnh nhiều nều cho vào file excel gốc sẽ rất nặng. Em muốn để ảnh ở 1 file excel khác, hoăc folder chứa ảnh. thì viết đường dẫn như thế nào để link với file gốc
Dòng code:
Set pic = Sheet5.Pictures(PicName)
Thay bằng dòng đường dẫn ntn?

Em cảm ơn
 

tueyennhi

Thành viên tích cực
Tham gia ngày
18 Tháng mười 2010
Bài viết
1,110
Được thích
92
Điểm
420
Tuổi
31
Điều đầu tiên bạn cần làm là sửa tên hình cho trùng với ID
Tiếp theo, mời xem qua topic này:
http://www.giaiphapexcel.com/forum/showthread.php?74484-Load-Shape-của-Sheet-lên-Button-của-Form/page2
Cuối cùng, xem ứng dụng trong file
Code trong UserForm chỉ có bao nhiêu đây thôi:
Mã:
Dim aSrc As Variant
Private Sub ListBox1_Click()
  Dim PicName As String, pic As Picture, IPic As IPictureDisp
  Dim lR As Long
  On Error Resume Next
  lR = ListBox1.ListIndex
  PicName = Me.ListBox1.List(lR, 0)
  Set pic = Sheet1.Pictures(PicName)
  Set IPic = PictureFromObject(pic, False)
  Image1.Picture = IPic
  TextBox1.Text = aSrc(lR + 1, 2)
  TextBox2.Text = aSrc(lR + 1, 3)
  TextBox3.Text = Format(aSrc(lR + 1, 4), "dd-MMM-yy")
  TextBox4.Text = Format(aSrc(lR + 1, 5), "dd-MMM-yy")
End Sub
Private Sub UserForm_Initialize()
  On Error Resume Next
  aSrc = Sheet1.Range("B2:F12").Value
  ListBox1.List = aSrc
  ListBox1.MultiSelect = fmMultiSelectSingle
  Image1.PictureSizeMode = fmPictureSizeModeStretch
End Sub
Private Sub CommandButton2_Click()
  Unload Me
End Sub
Đương nhiên phải có Module chứa hàm PictureFromObject. Hàm này bạn không cần quan tâm, chỉ cần biết áp dụng là được
Thầy cho em hỏi file này chỉ hiện được ảnh bitmap còn các định dạng khác ví dụ JPEG thì không được? Em thay ảnh khác vào thì không thấy hiện lên.
Bài đã được tự động gộp:

Thầy cho em hỏi file này chỉ hiện được ảnh bitmap còn các định dạng khác ví dụ JPEG thì không được? Em thay ảnh khác vào thì không thấy hiện lên.
À giờ em mới để ý tên ảnh phải đặt giống tên ID. Em làm được rồi thầy nhé. File này hay quá, cảm ơn thầy!
 

ndu96081631

Huyền thoại GPE
Thành viên BQT
Super Moderator
Tham gia ngày
5 Tháng sáu 2008
Bài viết
30,337
Được thích
52,767
Điểm
11,910
File này hay quá, cảm ơn thầy!
Bạn lưu ý hàm PictureFromObject được viết cho Office 32. Để có thể dùng cho mọi phiên bản, ta nên sửa thành vầy nhé
Mã:
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

#If VBA7 Then
  Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
  End Type
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As uPicDesc, _
                     RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
  Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
#Else
  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
#End If

Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
  #If VBA7 Then
    Dim hPtr As LongPtr, hCopy As LongPtr
  #Else
    Dim hPtr As Long, hCopy As Long
  #End If
  Dim 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 , IIf(bType, xlBitmap, xlPicture)
  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
 

tueyennhi

Thành viên tích cực
Tham gia ngày
18 Tháng mười 2010
Bài viết
1,110
Được thích
92
Điểm
420
Tuổi
31
Bạn lưu ý hàm PictureFromObject được viết cho Office 32. Để có thể dùng cho mọi phiên bản, ta nên sửa thành vầy nhé
Mã:
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

#If VBA7 Then
  Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
  End Type
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As uPicDesc, _
                     RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
  Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
#Else
  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
#End If

Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
  #If VBA7 Then
    Dim hPtr As LongPtr, hCopy As LongPtr
  #Else
    Dim hPtr As Long, hCopy As Long
  #End If
  Dim 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 , IIf(bType, xlBitmap, xlPicture)
  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
Vâng ạ, cảm ơn thầy!
 

sgtuntin

Thành viên mới
Tham gia ngày
6 Tháng một 2020
Bài viết
1
Được thích
0
Điểm
13
Tuổi
22
Bạn lưu ý hàm PictureFromObject được viết cho Office 32. Để có thể dùng cho mọi phiên bản, ta nên sửa thành vầy nhé
Mã:
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

#If VBA7 Then
  Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
  End Type
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As uPicDesc, _
                     RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
  Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
#Else
  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
#End If

Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
  #If VBA7 Then
    Dim hPtr As LongPtr, hCopy As LongPtr
  #Else
    Dim hPtr As Long, hCopy As Long
  #End If
  Dim 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 , IIf(bType, xlBitmap, xlPicture)
  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
E coppy paste rồi mà vẫn báo lỗi Cho e xin file module import cho máy 64bit đi ạ:)
 

ruaonline

Thành viên mới
Tham gia ngày
9 Tháng tư 2008
Bài viết
6
Được thích
1
Điểm
665
Tuổi
35
Bạn lưu ý hàm PictureFromObject được viết cho Office 32. Để có thể dùng cho mọi phiên bản, ta nên sửa thành vầy nhé
Mã:
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

#If VBA7 Then
  Private Type uPicDesc
    Size As Long
    Type As Long
    hPic As LongPtr
    hPal As LongPtr
  End Type
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As LongPtr
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As uPicDesc, _
                     RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As LongPtr, ByVal lpszFile As String) As LongPtr
  Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal Handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
#Else
  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
#End If

Function PictureFromObject(ByVal Target As Object, Optional ByVal bType As Boolean = True) As IPictureDisp
  #If VBA7 Then
    Dim hPtr As LongPtr, hCopy As LongPtr
  #Else
    Dim hPtr As Long, hCopy As Long
  #End If
  Dim 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 , IIf(bType, xlBitmap, xlPicture)
  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
Bác ndu96081631 ơi cứu cháu với ạ,
Cháu dùng code này để load ảnh từ worksheet lên userform, do có nhiều ảnh lên cháu dùng formulas (đặt tên và tìm kiếm ảnh qua hàm offset và index) => Để chỉ phải load ảnh này lên userform mà không phải đặt tên ảnh nhiều.
Quá trình test thì cứ lâu lâu khi mở file lên là ảnhbị thanh đổi kích thước, tìm mọi cách và google rồi mà cháu không khắc phục được ạ.
 

ruaonline

Thành viên mới
Tham gia ngày
9 Tháng tư 2008
Bài viết
6
Được thích
1
Điểm
665
Tuổi
35
Cháu đã khắc phục được lỗi kích thước ảnh, cháu cảm ơn nhiều ạ
 
Lần chỉnh sửa cuối:
Top Bottom