Em xin hướng dẫn cách chèn Picture từ Sheets vào Userform theo listbox với ạ

Chia sẻ bởi:hands

★★★★★

‹ [Xin giúp đỡ] Công thức tính tổng... Tách sheet từ dữ liệu đã PIVOT... ›

Quảng cáo

Xin anh(chị) giúp em đoạn code này với

Em muốn tạo 1 Userform gồm có 1 listbox có các lựa chọn (a,b,c,d) và 1 picture(1,2,3,4)
Khi chọn A thì hiện picture 1,
Khi chọn B thì hiện picture 2…. tương tự C D
Picture được lấy trong 1 sheets ạ
Xin anh(chị) giúp em đoạn code này với

Cái ý tưởng lưu hình ảnh ngay trong sheet Excel cũng hơi lạ đối với tôi. Excel nó không phải là CSDL có các tính năng để lưu trữ các đối tượng như hình ảnh, file v.v.. Nếu miễn cưỡng chèn hình ảnh vô thì ngày càng nặng file thêm chứ không ích lợi gì.
Cách tôi làm là có 1 folder riêng để lưu hình ảnh và trong sheet Excel (cell) khi cần thì link tới các file ảnh trong đó để hiển thị thôi.

Vâng ạ em có thử sang cách này, nhưng mà file ảnh nó ko được HD ạ có cách nào khắc phục chất lượng ảnh ko Bác

Bạn kiếm phần mềm nội suy điểm ảnh nhé, VBA thần thánh không làm được đâu . Neat image pro hay sao đó. Nó chỉ là tăng độ phân giải giả thôi.
Bài viết về load file ảnh vào sheet, userform, trên GPE này chắc có cả trăm bài. Bạn tìm kiếm thêm đi nhé.

Chia sẻ với bạn cách mà tôi hay làm đối với việc chèn hình minh họa cho từng record. Dùng Userform.
– Cách truyền thống này không bị cảnh báo vi rút nhé, mã nguồn mở, có thể tích hợp, tùy biến vô ứng dụng nào tương tự cũng được. 😎
– Tương thích mọi phiên bản bít (x86, x64).
– Có thể lấy file ảnh tên tiếng Việt có dấu luôn.
Quảng cáo đủ rồi, mời xem file đính kèm. 😀

7215

* Bổ sung thêm phiên bản dùng Class: clsLoadPicture

Option Explicit

Private mImageID As Variant
Private mImageCtl As Control
Private mImageFolderName As String

Public Property Let ImageID(vID As Variant)
    mImageID = vID
End Property

Public Property Get ImageID() As Variant
    ImageID = mImageID
End Property

Public Property Set ImageControl(ctl As Control)
    Set mImageCtl = ctl
End Property

Public Property Get ImageControl() As Control
    ImageControl = mImageCtl
End Property

Public Property Let ImageFolderName(sName As String)
    mImageFolderName = sName
End Property

Public Property Get ImageFolderName() As String
    ImageFolderName = mImageFolderName
End Property

Public Sub synImage()
On Error GoTo EH
    Dim defaultImage As String, savedImagePath As String
    defaultImage = ThisWorkbook.Path & "" & mImageFolderName & "" & "placeholder.bmp"
    savedImagePath = GetImagePath
    If checkFileExist(savedImagePath) = False Then
        mImageCtl.Picture = LoadPicture(defaultImage)
    Else
        mImageCtl.Picture = LoadPicture(savedImagePath)
    End If
    Exit Sub
EH:
    Select Case Err.Number
    Case 53, 76
        'MsgBox "Không tìm thay file anh", vbExclamation, AppName
    Case Else
        MsgBox "Err: " & Err.Number & vbCrLf & "Err content: " & Err.Description, vbCritical, AppName & " - SynImage"
    End Select
End Sub

Public Function GetImagePath() As String  'Dung variant vì imageID có the là Number, Text
    GetImagePath = ThisWorkbook.Path & "" & mImageFolderName & "" & mImageID & ".bmp"
End Function

Public Sub addImage()
    Dim strNewPicDest As String, sourceImagePath As String
    sourceImagePath = openImageFile
    If sourceImagePath = "" Then Exit Sub
    strNewPicDest = ThisWorkbook.Path & "" & mImageFolderName & "" & mImageID & ".bmp"
    FSO_FileCopy sourceImagePath, strNewPicDest
    synImage
End Sub

Public Function deleteImage()
    If checkFileExist(GetImagePath) = False Then Exit Function
    If MsgBox("Ban co chac muon xoa hình [" & ImageID & "]?", vbCritical + vbYesNo) = vbYes Then
        Kill GetImagePath
        synImage
    End If
End Function

Function checkCreateFolder(sFolderPath As String) As Boolean
    Dim FSO As Object
    On Error GoTo HandleError
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(sFolderPath) Then
        checkCreateFolder = True
    Else
        FSO.CreateFolder (sFolderPath)
        'MsgBox "It has been created.", vbInformation, "Create folder"
        checkCreateFolder = True
    End If

HandleExit:
    Exit Function
HandleError:
    checkCreateFolder = False
    MsgBox "Ma loi: " & Err.Number & vbCrLf & "Noi dung: " & Err.Description, vbCritical, "Check and create folder"
    Resume Next

End Function

Public Function FSO_FileCopy(ByVal sSource As String, ByVal sDest As String) As Boolean
    'On Error GoTo Error_Handler
    Dim oFSO As Object

Set oFSO = CreateObject("Scripting.FileSystemObject")
    Call oFSO.CopyFile(sSource, sDest, True)
    FSO_FileCopy = True

Error_Handler_Exit:
    On Error Resume Next
    If Not oFSO Is Nothing Then Set oFSO = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
        "Error Number: " & Err.Number & vbCrLf & _
        "Error Source: FSO_FileCopy" & vbCrLf & _
        "Error Description: " & Err.Description & _
        Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
        , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Function openImageFile() As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "Image Files", "*.bmp", 1
        .Title = "Choose an Image (.BMP) file:"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & "" & ImageFolderName
        If .Show = True Then
            openImageFile = .SelectedItems(1)
        End If
    End With
End Function

Private Sub Class_Terminate()
    On Error Resume Next
    '...
End Sub

www.giaiphapexcel.com/diendan/threads/em-xin-h%C6%B0%E1%BB%9Bng-d%E1%BA%ABn-c%C3%A1ch-ch%C3%A8n-picture-t%E1%BB%AB-sheets-v%C3%A0o-userform-theo-listbox-v%E1%BB%9Bi-%E1%BA%A1.160193/