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

AlanEvol · 29/4/22

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

ongke0711 · 29/4/22

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

Kiều Mạnh · 29/4/22

Tôi làm dịch vụ Viễn thông hay lưu hồ sơ + ảnh các kiểu vào File *.dat
nếu rảnh tôi viết lại hàm đó vào 1 DLL thì từ Excel cứ thế Call ... còn hiện tại là EXE
xem VD chơi chút cho vui thế thôi ...
Trong File có vài em Virus ... tôi mới xóa nó xong ... rảnh tôi viết lại úp cho ...
Virus là xóa thôi ko bao biện lý sự cùn

xem tạm File lưu ảnh vậy

AlanEvol · 29/4/22

ongke0711 đã viết:
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ài đã được tự động gộp: 29/4/22

Kiều Mạnh đã viết:
Tôi làm dịch vụ Viễn thông hay lưu hồ sơ + ảnh các kiểu vào File *.dat
nếu rảnh tôi viết lại hàm đó vào 1 DLL thì từ Excel cứ thế Call ... còn hiện tại là EXE
xem VD chơi chút cho vui thế thôi ...
Trong File có vài em Virus ... tôi mới xóa nó xong ... rảnh tôi viết lại úp cho ...
Virus là xóa thôi ko bao biện lý sự cùn

xem tạm File lưu ảnh vậy

Vâng em cảm ơn

ongke0711 · 29/4/22

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

Kiều Mạnh · 29/4/22

Tôi mới chỉnh lại chút từ 9 em Virus còn 3 em ... nhưng Windows ko xóa và Google ko có chặn lại úp lên cho ai đó tò mò thử chút
có 2 chức năng thêm ảnh và xóa Ảnh ... Sẻ Lỗi nếu Path + File là Unicode
Pass WinRaR là 123

ongke0711 · 1/5/22

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

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.

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

Mã:

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

AlanEvol · 15/5/22

Vâng em cảm ơn mọi người ạ. Em làm được rồi, em xin chân thành cảm ơn mấy anh

Maika8008 · 15/5/22

ongke0711 đã viết:

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.

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

Mã:

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

Hay lắm ông ké ơi!
Tui uýnh dấu bài này theo kiểu của tui á.

bda50dh · 28/6/23

ongke0711 đã viết:

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.

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

Mã:

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

Thật tuyệt vời anh ơi!nhưng không biết anh đã hoàn thiện xong chương trình này chưa ạ?

ongke0711 · 28/6/23

bda50dh đã viết:
Thật tuyệt vời anh ơi!nhưng không biết anh đã hoàn thiện xong chương trình này chưa ạ?

Tôi chỉ gửi file mẫu minh họa tính năng của chủ đề bài nay thôi nhé bạn.

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

AlanEvol

Thành viên mới

ongke0711

Thành viên gắn bó

Kiều Mạnh

I don't program, I beat code into submission!!!

File đính kèm

AlanEvol

Thành viên mới

ongke0711

Thành viên gắn bó

Kiều Mạnh

I don't program, I beat code into submission!!!

File đính kèm

ongke0711

Thành viên gắn bó

File đính kèm

AlanEvol

Thành viên mới

Maika8008

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

bda50dh

Thành viên mới

ongke0711

Thành viên gắn bó

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng