Nhờ các a/c sửa dùm code load picture from web lên userform

Liên hệ QC
G

guitarnguyen1989

Thành viên chính thức
Tham gia
31/7/16
Bài viết
59
Được thích
7
Dear A/C ! Help me.

Mình đang dùng 1 user form dùng để tra cứu hình ảnh sản phẩm.

Mình có ý tưởng hình ảnh sẽ được up lên một WEB , và mình sẽ lấy đường link gắn vào cột 6 theo tên sản phẩm ,khi mở user form và “CLICK” tới sản phẩm đó thì hình ảnh sẽ được load từ web và hiện lên trên khung image của userform.
NHƯNG CODE ĐANG BỊ LỖI NHỜ CÁC a/c XEM DÙM !
 

File đính kèm

  • PKLIST.xlsm
    2.4 MB · Đọc: 16
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Mã: 
sArray = Range("Maindata").Value    
lst_Employee_info.List() = sArray
Nhập vùng "Maindata" =TCCR!$A$4:$E$12 vào ListBox. Tức trong ListBox chỉ có 5 cột với chỉ số 0, 1, 2, 3, 4.

Sau đó
Mã: 
On Error Resume Next
...
PICTURENAME = frm_EmployInfo.lst_Employee_info.List(LisRow, 5)
tức truy cập tới cột có chỉ số 5, do vậy có lỗi. Nhưng do On Error Resume Next nên code đi tiếp nhưng PICTURENAME = "", tức vô dụng, và sẽ lỗi ở các bước tiếp theo.

Cho dù có sửa lại thành ...List(LisRow, 4) thì cái đọc ra nó là ĐVT (cột E) chứ không là link.

Vậy phải sửa name thành =TCCR!$A$4:$F$12 và giữ nguyên ...List(LisRow, 5)

Tuy nhiên với các link như thế thì LoadPicture không chấp nhận. Tôi chưa bao giờ thử trong mạng LAN nhưng tôi tin là LoadPicture chấp nhân các link trong mạng LAN.

Với link của bạn thì vd. có ít nhất 2 cách:

1. Khi click ListBox thì đọc ra PICTURENAME -> tạo picture trên sheet và load ảnh vào nó - sheet.Pictures.Insert(link) -> từ ảnh trên sheet tạo IPictureDisp
và nhập vào Image trên Form.

Có quá nhiều việc.

2. Khi có PICTURENAME thì tải về máy và load từ tập tin trên đĩa. Khi mở Form tạo 1 thư mục temp. Nếu có ít link thì tải các ảnh về temp. Khi click ListBox thì load ảnh từ temp. Nếu nhiều link thì khi click kiểm tra đã có ảnh thích hợp chưa. Nếu chưa thì tải về temp -> load từ temp + ghi nhớ là link ấy đã được tải. Khi đóng Form thì xóa temp.
 
Upvote 0
UP ! help
Bài đã được tự động gộp:

Thanks batman1 ! Bạn có thể giúp mình code theo cách 2 ??? help

Với link của bạn thì vd. có ít nhất 2 cách:

1. Khi click ListBox thì đọc ra PICTURENAME -> tạo picture trên sheet và load ảnh vào nó - sheet.Pictures.Insert(link) -> từ ảnh trên sheet tạo IPictureDisp
và nhập vào Image trên Form.

Có quá nhiều việc.

2. Khi có PICTURENAME thì tải về máy và load từ tập tin trên đĩa. Khi mở Form tạo 1 thư mục temp. Nếu có ít link thì tải các ảnh về temp. Khi click ListBox thì load ảnh từ temp. Nếu nhiều link thì khi click kiểm tra đã có ảnh thích hợp chưa. Nếu chưa thì tải về temp -> load từ temp + ghi nhớ là link ấy đã được tải. Khi đóng Form thì xóa temp.[/QUOTE]
 
Upvote 0
guitarnguyen1989 đã viết:
UP ! help
Bài đã được tự động gộp:

Cảm ơn batman1 ! Bạn có thể giúp mình code theo cách 2 ??? help
Nhấp chuột vào đây để mở rộng...
1. Trong Module5 thêm
Mã: 
Public Function URLToFile(ByVal url As String, ByVal localFolder As String) As String
Dim fullfilename As String, xml As Object
    If VBA.Right(localFolder, 1) <> "\" Then localFolder = localFolder & "\"
    fullfilename = localFolder & VBA.Mid(url, InStrRev(url, "/") + 1, Len(url))
    Set xml = CreateObject("msxml2.xmlhttp")
    xml.Open "GET", url, False
    xml.send
    If xml.Status = 200 Then
        With CreateObject("ADODB.Stream")
            .Open
            .Type = 1
            .Write xml.ResponseBody
            .Position = 0
            .SaveToFile fullfilename, 2
            .Close
        End With
    End If
    Set xml = Nothing
    URLToFile = fullfilename
End Function
2. Trong code của Form sửa Sub UserForm_Initialize và Sub lst_Employee_info_Click thành
Mã: 
Private Sub UserForm_Initialize()
Dim lastRow As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    
    On Error Resume Next
    MkDir ThisWorkbook.path & "\myTemp"
    On Error GoTo 0
    
    With ThisWorkbook.Worksheets("TCCR")
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
        If lastRow > 3 Then
            sArray = .range("A4:F" & lastRow).Value
'            them  cot de ghi ten tap tin anh tai ve
            ReDim Preserve sArray(1 To UBound(sArray), 1 To UBound(sArray, 2) + 1)
            lst_Employee_info.List = sArray
        End If
        sArray = range("Maindata").Value
    End With
    CBDMHH.List = Sheet1.[A1:A3].Value
    CBDMHH.Value = "ALL"
End Sub

Private Sub lst_Employee_info_Click()
Dim localfile As String
    LisRow = frm_EmployInfo.lst_Employee_info.ListIndex
    If LisRow = -1 Then Exit Sub
'    neu da tai truoc do thi cot 6 chua duong dan tap tin tai ve
    PICTURENAME = lst_Employee_info.List(LisRow, 6)

    Txt_ma.Value = lst_Employee_info.List(LisRow, 2)
    Txt_tentp.Value = lst_Employee_info.List(LisRow, 3)
'    neu chua tai anh ve thi tai ve
    If PICTURENAME = "" Then PICTURENAME = URLToFile(lst_Employee_info.List(LisRow, 5), ThisWorkbook.Path & "\myTemp")
'    ghi duong dan tap tin tai ve vao cot 6 de sau do neu chon lai dong do thi khong can tai ve nua
    lst_Employee_info.List(LisRow, 6) = PICTURENAME
'    nhap anh vao Image
    img_EmployPict.Picture = LoadPicture(PICTURENAME)
End Sub

3. Trong code của Form thêm
Mã: 
Private Sub UserForm_Terminate()
    On Error Resume Next
    RmDir ThisWorkbook.Path & "\myTemp"
    On Error GoTo 0
End Sub

Sau khi sửa thì tìm trong tất cả các module thấy code nào không cần thiết nữa thì tự xóa, vd. Sub ListBox_Click trong Module5.

Lẽ ra chỉ cần load lên ListBox các cột B:F, nhưng nếu tôi load thế thì phải sửa các chỉ số vd. trong Sub lst_Employee_info_Change và Sub txt_search_Change. Mà tôi không có hứng. Thôi thì cứ để như bạn là cột đầu có độ rộng = 0.

4. Chuyển các tập tin trên mạng về BMP, JPG, GIF, WMF hoặc EMF. LoadPicture không chấp nhận PNG.

Do không có tập tin ảnh để test (chỉ có PNG) nên tôi viết chay thôi. Có thể có chỗ thừa thiếu dấu phẩy và phát sinh lỗi.

Tôi chỉ giúp phần ảnh. Toàn bộ các việc khác nếu cần thì đợi người khác giúp.
 
Upvote 0
Trong Sub UserForm_Initialize tôi quên chưa xóa
Mã: 
sArray = range("Maindata").Value
Cái kiểu viết chay không test được nó thế đấy.
 
Upvote 0
batman1 đã viết:
1. Trong Module5 thêm
Mã: 
Public Function URLToFile(ByVal url As String, ByVal localFolder As String) As String
Dim fullfilename As String, xml As Object
    If VBA.Right(localFolder, 1) <> "\" Then localFolder = localFolder & "\"
    fullfilename = localFolder & VBA.Mid(url, InStrRev(url, "/") + 1, Len(url))
    Set xml = CreateObject("msxml2.xmlhttp")
    xml.Open "GET", url, False
    xml.send
    If xml.Status = 200 Then
        With CreateObject("ADODB.Stream")
            .Open
            .Type = 1
            .Write xml.ResponseBody
            .Position = 0
            .SaveToFile fullfilename, 2
            .Close
        End With
    End If
    Set xml = Nothing
    URLToFile = fullfilename
End Function
2. Trong code của Form sửa Sub UserForm_Initialize và Sub lst_Employee_info_Click thành
Mã: 
Private Sub UserForm_Initialize()
Dim lastRow As Long
    Set Dic = CreateObject("Scripting.Dictionary")
   
    On Error Resume Next
    MkDir ThisWorkbook.path & "\myTemp"
    On Error GoTo 0
   
    With ThisWorkbook.Worksheets("TCCR")
        lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
        If lastRow > 3 Then
            sArray = .range("A4:F" & lastRow).Value
'            them  cot de ghi ten tap tin anh tai ve
            ReDim Preserve sArray(1 To UBound(sArray), 1 To UBound(sArray, 2) + 1)
            lst_Employee_info.List = sArray
        End If
        sArray = range("Maindata").Value
    End With
    CBDMHH.List = Sheet1.[A1:A3].Value
    CBDMHH.Value = "ALL"
End Sub

Private Sub lst_Employee_info_Click()
Dim localfile As String
    LisRow = frm_EmployInfo.lst_Employee_info.ListIndex
    If LisRow = -1 Then Exit Sub
'    neu da tai truoc do thi cot 6 chua duong dan tap tin tai ve
    PICTURENAME = lst_Employee_info.List(LisRow, 6)

    Txt_ma.Value = lst_Employee_info.List(LisRow, 2)
    Txt_tentp.Value = lst_Employee_info.List(LisRow, 3)
'    neu chua tai anh ve thi tai ve
    If PICTURENAME = "" Then PICTURENAME = URLToFile(lst_Employee_info.List(LisRow, 5), ThisWorkbook.Path & "\myTemp")
'    ghi duong dan tap tin tai ve vao cot 6 de sau do neu chon lai dong do thi khong can tai ve nua
    lst_Employee_info.List(LisRow, 6) = PICTURENAME
'    nhap anh vao Image
    img_EmployPict.Picture = LoadPicture(PICTURENAME)
End Sub

3. Trong code của Form thêm
Mã: 
Private Sub UserForm_Terminate()
    On Error Resume Next
    RmDir ThisWorkbook.Path & "\myTemp"
    On Error GoTo 0
End Sub

Sau khi sửa thì tìm trong tất cả các module thấy code nào không cần thiết nữa thì tự xóa, vd. Sub ListBox_Click trong Module5.

Lẽ ra chỉ cần load lên ListBox các cột B:F, nhưng nếu tôi load thế thì phải sửa các chỉ số vd. trong Sub lst_Employee_info_Change và Sub txt_search_Change. Mà tôi không có hứng. Thôi thì cứ để như bạn là cột đầu có độ rộng = 0.

4. Chuyển các tập tin trên mạng về BMP, JPG, GIF, WMF hoặc EMF. LoadPicture không chấp nhận PNG.

Do không có tập tin ảnh để test (chỉ có PNG) nên tôi viết chay thôi. Có thể có chỗ thừa thiếu dấu phẩy và phát sinh lỗi.

Tôi chỉ giúp phần ảnh. Toàn bộ các việc khác nếu cần thì đợi người khác giúp.
Nhấp chuột vào đây để mở rộng...
Thank you so much !!! batman1
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
Sao Filter của Excel kỳ lạ.
Trả lời
1
Đọc
2
BuiQuangThuan
B
T
[Giúp đỡ] Tìm số lượng nhân viên đã tham gia làm lô hàng
Trả lời
3
Đọc
64
hoangtuaotrang_hp_vn
H
hoang.buivan93
Gặp rắc rối về phần công thức hàm tìm kiếm dữ liệu. Nhờ mọi người chỉ giáo giúp ạ.
Trả lời
1
Đọc
36
Hoàng Trọng Nghĩa
Hoàng Trọng Nghĩa
quangminhici
Tặng Addin Word xuất Mail Merge có chức năng cắt ra nhiều file và gửi mail.
    • Thích
Trả lời
8
Đọc
949
thientac
T
A
[Cần Giúp] Excel nhiều người dùng cùng lúc
Trả lời
5
Đọc
121
hvnhpro
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom