Chuyển ảnh từ File Excel lên Form

[thang_nguyen1]

Chào các bạn. Cho mình hỏi có thể dùng VBA chuyển hỉnh ảnh từ File Excel lên form được không? Mong các bạn giúp mình với. Mình xin cảm ơn!

 

[Cafe Kem No.1]

Xin chào các bác,
Dựa trên đề tài này, em nhờ các bác giúp em phát triển thêm như bên dưới được không?
- Có một cột B bắt đầu từ B4:B1000 sẽ gồm những hyperlink đến địa chỉ hình ảnh (có thể là ảnh online hoặc offline).
- Khi mình click chuột vào ô nào thuộc B4:B1000 thì sẽ hiện ra ảnh lên form.
- Form hiển thị ảnh sẽ tự động thay đổi kích thước dựa theo ảnh gốc (tối đa là full screen).

 

[Yêu thich VBA]

Em nghĩ là khi bạn ấy tạo add-in là muốn xem popup hình trên 1 file bình thường (.xlsx) bất kỳ. Khi bật add-in thì có thêm tính năng click vào hình để xem.
Ý tưởng là:
Trong add-in Chạy một đoạn mã tự động gán OnAction = "ClickMe" cho mọi ảnh trong ActiveSheet, trong đó thì ClickMe được lấy từ trong add-in ra. Có thể là OnAction = "'" & addInName & "'!" & macroName

Mình có giải pháp khác.
Nhúng ảnh lên userform rất dễ ( xem sản phẩm tôi đã nhúng anh của tôi vào hồ sơ xin việc...trong file Dich 6 ngôn ngữ)
Gán các nút nhấn vào Add in xong ....thì mở fie excel nào nó cũng đi theo...muốn dịch chữ nào nó dịch chữ đó...)
Bạn mở 3 file mình gửi nhé. Trong file có số ĐT zalo của mình đấy.
Ultraview lên mình trợ giúp bạn

 

[hoangtuan.net]

Mình có giải pháp khác.
Nhúng ảnh lên userform rất dễ ( xem sản phẩm tôi đã nhúng anh của tôi vào hồ sơ xin việc...trong file Dich 6 ngôn ngữ)
Gán các nút nhấn vào Add in xong ....thì mở fie excel nào nó cũng đi theo...muốn dịch chữ nào nó dịch chữ đó...)
Bạn mở 3 file mình gửi nhé. Trong file có số ĐT zalo của mình đấy.
Ultraview lên mình trợ giúp bạn

Dạ bác, nay em mới quay lại với diễn đàn. Để em nghiên cứu có gì không hiểu mong được bác giúp đỡ ạ!

 

[luong96]

Chèn đoạn code này vào Module.

Option Explicit
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

Tiếp theo thêm đoạn code này vào UserForm.

Private Sub UserForm_Initialize()
Image1.Picture = PictureFromObject(Sheets("sheet1").Shapes("Picture 2"))
End Sub

Việc còn lại là cho UserForm nó Show lên.

cái này có phải áp dụng win API phải không ạ? hay làm bằng cái gì thế anh vì em thấy nhiều cú pháp lạ quá, không thấy nhiều trong vba excel