Đưa ảnh hiện vào khung (TextBox) bằng VBA

MinhKhai · 12/8/13

Mình sưu tầm được code VBA của file đính kèm. Do trình độ non yếu nên không biết các sửa, nay nhờ các bác giúp hộ:
1. Đưa ảnh hiện vào 1 khung.
2. Thay đổi E8 thì ảnh hiện theo
3. Tăng tốc độ tải ảnh. (Em đang up ảnh vào SkyDrive, không biết tốc độ tải ảnh ở trang này có chậm không?)

https://dl.dropboxusercontent.com/s...puKcjnCv-JWRnSBfa2ieLffKGNZy7w0fUh9hM2nA&dl=1

ndu96081631 · 13/8/13

MinhKhai đã viết:
3. Tăng tốc độ tải ảnh. (Em đang up ảnh vào SkyDrive, không biết tốc độ tải ảnh ở trang này có chậm không?)

Trả lời câu hỏi này trước: Vì phải tải ảnh từ Internet về máy tính nên tốc độ chậm là phải rồi (có tăng tốc kiểu nào thì vẫn chậm)
Vậy sao bạn không download toàn bộ ảnh về máy tính trước (có thể download bằng tay hoặc dùng code) rồi hẳn chèn hình vào bảng tính? Khi ấy hình được lấy từ ổ cứng sẽ nhanh hơn
(Code dạng này tôi đã viết từ lâu rồi nhưng cũng bởi vì vấn đề tốc độ nên tôi không đưa lên diễn đàn)

ndu96081631 · 13/8/13

MinhKhai đã viết:
Mình sưu tầm được code VBA của file đính kèm. Do trình độ non yếu nên không biết các sửa, nay nhờ các bác giúp hộ:
1. Đưa ảnh hiện vào 1 khung.
2. Thay đổi E8 thì ảnh hiện theo

Trả lời tiếp 2 yêu cầu này:
1> Để có khung ảnh, ta vẽ 1 Rectangle, đặt tên cho nó là PicFrame (từ đây ảnh sẽ được chèn vào khung này
2> Để ảnh thay đổi theo E8, dùng sự kiện WorksheetChange:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim strPic
  On Error Resume Next
  If Target.Address = "$E$8" Then
    strPic = Target.Parent.Range("K4").Value
    With Sheet1.Shapes("PicFrame").Fill
      If strPic <> 0 Then
        .UserPicture CStr(strPic)
      Else
        .Solid: .ForeColor.SchemeColor = 12
      End If
    End With
  End If
End Sub

Tóm lại: Code chỉ nhiêu đó (hãy xóa toàn bộ những code đang có của bạn)

MinhKhai · 13/8/13

ndu96081631 đã viết:
Trả lời câu hỏi này trước: Vì phải tải ảnh từ Internet về máy tính nên tốc độ chậm là phải rồi (có tăng tốc kiểu nào thì vẫn chậm)
Vậy sao bạn không download toàn bộ ảnh về máy tính trước (có thể download bằng tay hoặc dùng code) rồi hẳn chèn hình vào bảng tính? Khi ấy hình được lấy từ ổ cứng sẽ nhanh hơn
(Code dạng này tôi đã viết từ lâu rồi nhưng cũng bởi vì vấn đề tốc độ nên tôi không đưa lên diễn đàn)

Em cũng đã gặp 1 vài file mẫu mà họ tải ảnh vào 1 thư mục. Tuy nhiên em vẫn chọn cách up ảnh lên Internet
- Người dùng chỉ copy 1 file excel là xong. (Gọn nhẹ)
- Em chủ động thay ảnh đã up trên Internet mà ko cần can thiệp vào file mình đã gửi đi.

MinhKhai · 13/8/13

ndu96081631 đã viết:
Trả lời tiếp 2 yêu cầu này:
1> Để có khung ảnh, ta vẽ 1 Rectangle, đặt tên cho nó là PicFrame (từ đây ảnh sẽ được chèn vào khung này
2> Để ảnh thay đổi theo E8, dùng sự kiện WorksheetChange:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) Dim strPic On Error Resume Next If Target.Address = "$E$8" Then strPic = Target.Parent.Range("K4").Value With Sheet1.Shapes("PicFrame").Fill If strPic <> 0 Then .UserPicture CStr(strPic) Else .Solid: .ForeColor.SchemeColor = 12 End If End With End If End Sub

Tóm lại: Code chỉ nhiêu đó (hãy xóa toàn bộ những code đang có của bạn)

Chân thành cảm ơn bác. Trước hết vì bác rất nhiệt tình giúp đỡ và chỉ dẫn mọi người, sau đó vì code của bác rất gọn, rất "trong sáng" nên dễ hiểu để học tập và giải quyết các yêu cầu khác. Em hoàn toàn hài lòng vì giải pháp của bác

ndu96081631 · 13/8/13

MinhKhai đã viết:
Em cũng đã gặp 1 vài file mẫu mà họ tải ảnh vào 1 thư mục. Tuy nhiên em vẫn chọn cách up ảnh lên Internet
- Người dùng chỉ copy 1 file excel là xong. (Gọn nhẹ)
- Em chủ động thay ảnh đã up trên Internet mà ko cần can thiệp vào file mình đã gửi đi.

Đương nhiên giải pháp Upload ảnh lên internet là hợp lý rồi (tôi có nói gì đâu)
Ý tôi là: Thay vì insert ảnh trực tiếp từ internet, ta thêm công đoạn download ảnh về máy tính rồi hẳn insert. Vậy thì tốc độ chắc chắn sẽ ngon lành
Quy trình tôi đề xuất là thế này:
- Tạo Sub AutoOpen làm nhiệm vụ (ngay từ khi khởi động file) download toàn bộ ảnh về đâu đó trên ổ cứng, đông thời đặt tên cho ảnh theo đúng mã số
- Sub AutoOpen cũng làm thêm 1 công đoạn nữa là kiểm tra xem tên file ảnh đã tồn tại trong ổ cứng hay chưa ---> Nếu chưa có mới download. Điều này giúp giảm nhẹ công việc khi mở file lần thứ 2 sẽ không phải download tiếp
- Khi thực thi công đoạn chèn ảnh, sẽ lấy ảnh từ ổ cứng thay vì lấy ảnh từ internet
- Khi chuyển file sang máy tính khác thì công việc download ảnh sẽ được thực thi (và chỉ thực thi 1 lần duy nhất)

maytinhvp01 · 13/8/13

ndu96081631 đã viết:
Đương nhiên giải pháp Upload ảnh lên internet là hợp lý rồi (tôi có nói gì đâu)
Ý tôi là: Thay vì insert ảnh trực tiếp từ internet, ta thêm công đoạn download ảnh về máy tính rồi hẳn insert. Vậy thì tốc độ chắc chắn sẽ ngon lành
Quy trình tôi đề xuất là thế này:
- Tạo Sub AutoOpen làm nhiệm vụ (ngay từ khi khởi động file) download toàn bộ ảnh về đâu đó trên ổ cứng, đông thời đặt tên cho ảnh theo đúng mã số
- Sub AutoOpen cũng làm thêm 1 công đoạn nữa là kiểm tra xem tên file ảnh đã tồn tại trong ổ cứng hay chưa ---> Nếu chưa có mới download. Điều này giúp giảm nhẹ công việc khi mở file lần thứ 2 sẽ không phải download tiếp
- Khi thực thi công đoạn chèn ảnh, sẽ lấy ảnh từ ổ cứng thay vì lấy ảnh từ internet
- Khi chuyển file sang máy tính khác thì công việc download ảnh sẽ được thực thi (và chỉ thực thi 1 lần duy nhất)

Đọc bài của bác mà tự hỏi không biết tới lúc nào có thể hiểu được 70% VBA

maytinhvp01 · 13/8/13

ndu96081631 đã viết:
Trả lời tiếp 2 yêu cầu này:
1> Để có khung ảnh, ta vẽ 1 Rectangle, đặt tên cho nó là PicFrame (từ đây ảnh sẽ được chèn vào khung này
2> Để ảnh thay đổi theo E8, dùng sự kiện WorksheetChange:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) Dim strPic On Error Resume Next If Target.Address = "$E$8" Then strPic = Target.Parent.Range("K4").Value With Sheet1.Shapes("PicFrame").Fill If strPic <> 0 Then .UserPicture CStr(strPic) Else .Solid: .ForeColor.SchemeColor = 12 End If End With End If End Sub

Tóm lại: Code chỉ nhiêu đó (hãy xóa toàn bộ những code đang có của bạn)

Hướng dẫn em cách đổi tên rectangle với ạ. có phải câu lệch này dùng đổi tên luôn không hả anh?

With Sheet1.Shapes("PicFrame").Fill
Em đã test thì thấy code anh load ảnh nhanh hơn file cũ.

MinhKhai · 13/8/13

maytinhvp01 đã viết:
Hướng dẫn em cách đổi tên rectangle với ạ
Em đã test thì thấy code anh load ảnh nhanh hơn file cũ.

Bạn vẽ rectangle. Đánh dấu vào Rectangle này. Nhìn vào cái hộp Name Box, nó đang có cái tên mặc định gì đó ví dụ như Rectangle 2. Bạn bôi đen dòng chữ này và gõ tên mới (ví dụ PicFrame) rồi gõ Enter là xong.

Hộp Name Box ở sát phía trên ô A1. (Góc trên trái màn hình)

MinhKhai · 13/8/13

ndu96081631 đã viết:
Đương nhiên giải pháp Upload ảnh lên internet là hợp lý rồi (tôi có nói gì đâu)
Ý tôi là: Thay vì insert ảnh trực tiếp từ internet, ta thêm công đoạn download ảnh về máy tính rồi hẳn insert. Vậy thì tốc độ chắc chắn sẽ ngon lành
Quy trình tôi đề xuất là thế này:
- Tạo Sub AutoOpen làm nhiệm vụ (ngay từ khi khởi động file) download toàn bộ ảnh về đâu đó trên ổ cứng, đông thời đặt tên cho ảnh theo đúng mã số
- Sub AutoOpen cũng làm thêm 1 công đoạn nữa là kiểm tra xem tên file ảnh đã tồn tại trong ổ cứng hay chưa ---> Nếu chưa có mới download. Điều này giúp giảm nhẹ công việc khi mở file lần thứ 2 sẽ không phải download tiếp
- Khi thực thi công đoạn chèn ảnh, sẽ lấy ảnh từ ổ cứng thay vì lấy ảnh từ internet
- Khi chuyển file sang máy tính khác thì công việc download ảnh sẽ được thực thi (và chỉ thực thi 1 lần duy nhất)

Ý tưởng của bác rất hay, như cách các trang tải các trang web. Khi mở file Excel sẽ ra lệnh down các ảnh về thư mục tạm đồng thời --> đổi tên. Tuy nhiên có vấn đề như sau:
1. Khi mở file (Aut

pen) lệnh download ảnh sẽ thực thi, nó sẽ download tất cả các ảnh (giả sử chưa có sẵn ảnh trong thư mục tạm) điều này sẽ khiến thời gian mở file sẽ lâu (thậm chí rất lâu) --> Gây tâm lý khó chịu cho người dùng file.
2. Em rất tán thành phương án của bác, nhưng code thế nào thì em pótay.com

ndu96081631 · 13/8/13

MinhKhai đã viết:
Ý tưởng của bác rất hay, như cách các trang tải các trang web. Khi mở file Excel sẽ ra lệnh down các ảnh về thư mục tạm đồng thời --> đổi tên. Tuy nhiên có vấn đề như sau:
1. Khi mở file (Autpen) lệnh download ảnh sẽ thực thi, nó sẽ download tất cả các ảnh (giả sử chưa có sẵn ảnh trong thư mục tạm) điều này sẽ khiến thời gian mở file sẽ lâu (thậm chí rất lâu) --> Gây tâm lý khó chịu cho người dùng file.
2. Em rất tán thành phương án của bác, nhưng code thế nào thì em pótay.com

Tốc độ ra sao cứ thử sẽ biết hen:
1> Code trong Module

Mã:

Function DownloadFile(ByVal URL As String, ByVal FileToSave As String) As String
  Dim oXlmHttp As Object, fso As Object
  Dim tmpPath As String
  On Error Resume Next
  Set fso = CreateObject("Scripting.FileSystemObject")
  tmpPath = fso.BuildPath(Environ("TEMP"), FileToSave)
  If Not fso.FileExists(tmpPath) Then
    Set oXlmHttp = CreateObject("Microsoft.XMLHTTP")
    oXlmHttp.Open "GET", URL, False
    oXlmHttp.Send
    URL = oXlmHttp.ResponseBody
    If oXlmHttp.Status = 200 Then
      With CreateObject("ADODB.Stream")
        .Open: .Type = 1
        .Write oXlmHttp.ResponseBody
        .SaveToFile tmpPath
        .Close
      End With
    End If
  End If
  DownloadFile = tmpPath
End Function
Sub Auto_Open()
  Dim aSrc, Ret As String, lR As Long
  On Error Resume Next
  aSrc = Sheets("Data").Range("All").Value
  For lR = 1 To UBound(aSrc, 1)
    Ret = DownloadFile(aSrc(lR, 28), aSrc(lR, 1))
  Next
End Sub

2> Code sự kiện Change

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim sPic As String, sURL As String
  On Error Resume Next
  If Target.Address = "$E$8" Then
    sURL = Target.Parent.Range("K4").Value
    With Sheet1.Shapes("PicFrame").Fill
      .Solid: .ForeColor.SchemeColor = 12
      If Len(Trim(sURL)) Then
        sPic = DownloadFile(sURL, Target.Value)
        If Len(sPic) Then .UserPicture sPic
      End If
    End With
  End If
End Sub

--------------
Thử nghiệm:
- Mở file và chờ trong giây lát. Đến khi hoàn tất, thực hiện code Change bằng cách thay đổi Validation tai E8 ---> Cảm nhận tốc độ
- Đóng file lại và mở lần nữa để kiểm tra
Chắc chắn từ lần mở file thứ 2 trở đi sẽ không phải chờ đợi gì cả

maytinhvp01 · 13/8/13

MinhKhai đã viết:
Bạn vẽ rectangle. Đánh dấu vào Rectangle này. Nhìn vào cái hộp Name Box, nó đang có cái tên mặc định gì đó ví dụ như Rectangle 2. Bạn bôi đen dòng chữ này và gõ tên mới (ví dụ PicFrame) rồi gõ Enter là xong.

Hộp Name Box ở sát phía trên ô A1. (Góc trên trái màn hình)

Mình thấy rùi bên trái dong để nhập công thức đúng không? Cảm ơn bạn! sem nào tối nay lại "vọc" tiếp tác phẩm của topic này hihi
Tình hình là mình không đổi tên được bạn àh giúp mình với

maytinhvp01 · 13/8/13

ndu96081631 đã viết:
Trả lời tiếp 2 yêu cầu này:
1> Để có khung ảnh, ta vẽ 1 Rectangle, đặt tên cho nó là PicFrame (từ đây ảnh sẽ được chèn vào khung này
2> Để ảnh thay đổi theo E8, dùng sự kiện WorksheetChange:

Mã:

Private Sub Worksheet_Change(ByVal Target As Range) Dim strPic On Error Resume Next If Target.Address = "$E$8" Then strPic = Target.Parent.Range("K4").Value With Sheet1.Shapes("PicFrame").Fill If strPic <> 0 Then .UserPicture CStr(strPic) Else .Solid: .ForeColor.SchemeColor = 12 End If End With End If End Sub

Tóm lại: Code chỉ nhiêu đó (hãy xóa toàn bộ những code đang có của bạn)

Anh ơi đổi tên rectangle như thế nào ạh.

ndu96081631 · 13/8/13

maytinhvp01 đã viết:
Tình hình là mình không đổi tên được bạn àh giúp mình với

Gì vậy?
Xem video clip này nhé:

[video=youtube;DVr20QW_xRI]http://www.youtube.com/watch?v=DVr20QW_xRI&feature=youtu.be[/video]

Đổi tên bình thường mà

maytinhvp01 · 13/8/13

Cảm ơn anh. Em xin bổ xung thêm là khi đánh xong tên mới kết thúc phải là nhấn "enter" mới đỏi tên được. khi trước em đánh xong tên em kích chuột vào luôn bảng tính hay cho nào đó nên tên không đổi được. Thank!

maytinhvp01 · 14/8/13

ndu96081631 đã viết:
Gì vậy?
Xem video clip này nhé:
Đổi tên bình thường mà

Anh ơi em vẫn đang tìm hiểu cái bài này. Anh chỉ em cách làm tại cái cell E8 với ạ. Làm sao để tạo được cái list đó hả anh?
Anh oi em đã tim trên diễn đàn và tìm được bài anh hướng dẫn trước đó. Nhưng bài hướng dẫn đó lại là combo box (activax control). Em có thử làm như hướng dẫn về cái combo box (activax control) nhưng khi lấy listfillrange tham chieu sang sheet khác thì không biết làm " em thay trên thẻ properties của combo. anh hướng dẫn em với ạh

ndu96081631 · 15/8/13

maytinhvp01 đã viết:
Anh ơi em vẫn đang tìm hiểu cái bài này. Anh chỉ em cách làm tại cái cell E8 với ạ. Làm sao để tạo được cái list đó hả anh?

Cái đó gọi là Validation bạn à!
Bạn tự tìm trong Excel (Tab Data\Data Validation) hoặc tìm trên GPE ---> Có đầy

maytinhvp01 · 15/8/13

ndu96081631 đã viết:
Cái đó gọi là Validation bạn à!
Bạn tự tìm trong Excel (Tab Data\Data Validation) hoặc tìm trên GPE ---> Có đầy

Thank anh nhiều em se tìm hiểu phần validation này ạ!

phieudu_90 · 13/2/14

Chào anh ndu96081631
Cũng như yêu cầu trên nhưng code để chèn ảnh đã có ở máy tính vào textbox đó như thế nào ạ?

maytinhvp01 · 13/2/14

phieudu_90 đã viết:
Chào anh ndu96081631
Cũng như yêu cầu trên nhưng code để chèn ảnh đã có ở máy tính vào textbox đó như thế nào ạ?

Em mượn code anh Ndu:
Với bài trên mà lấy ảnh ở máy bạn thì chố màu đỏ tùy biến theo đường dẫn của file ảnh của bạn

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim strPic
  On Error Resume Next
  If Target.Address = "$E$8" Then
    strPic = [COLOR=#ff0000]Target.Parent.Range("K4").Value[/COLOR][B][COLOR=#000080] ' có thể tùy biến theo chỗ này[/COLOR][/B]
    With Sheet1.Shapes("PicFrame").Fill
      If strPic <> 0 Then
        .UserPicture [COLOR=#ff0000]CStr(strPic)[/COLOR][B][COLOR=#000080] 'hoặc chỗ này[/COLOR][/B]
      Else
        .Solid: .ForeColor.SchemeColor = 12
      End If
    End With
  End If
End Sub

hơn nữa cấu hởi của bạn là đưa ảnh vào "textbox" là đưa danh sách hay cái gì vây???

Đưa ảnh hiện vào khung (TextBox) bằng VBA

Giải pháp Ếc-xào

Huyền thoại GPE

Huyền thoại GPE

File đính kèm

Giải pháp Ếc-xào

Giải pháp Ếc-xào

Huyền thoại GPE

Thành viên thường trực

Thành viên thường trực

Giải pháp Ếc-xào

Giải pháp Ếc-xào

Huyền thoại GPE

File đính kèm

Thành viên thường trực

Thành viên thường trực

Huyền thoại GPE

Thành viên thường trực

Thành viên thường trực

Huyền thoại GPE

Thành viên thường trực

Thành viên mới

Thành viên thường trực