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

Liên hệ QC
MinhKhai

MinhKhai

Giải pháp Ếc-xào
Tham gia
16/4/08
Bài viết
934
Được thích
569
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
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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?)
Nhấp chuột vào đây để mở rộ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)
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...

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)
 

File đính kèm

  • TT_DangVien1.rar
    46.4 KB · Đọc: 551
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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.
Nhấp chuột vào đây để mở rộng...

Đươ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)
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...

Đọ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
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
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ũ.
 
Lần chỉnh sửa cuối:
Upvote 0
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ũ.
Nhấp chuột vào đây để mở rộng...
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)
 
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...
Ý 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 (Auto_Open) 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
 
Upvote 0
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 (Auto_Open) 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
Nhấp chuột vào đây để mở rộng...

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ả
 

File đính kèm

  • PictureFromWeb.rar
    828.3 KB · Đọc: 324
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...

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
 
Lần chỉnh sửa cuối:
Upvote 0
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)
Nhấp chuột vào đây để mở rộng...

Anh ơi đổi tên rectangle như thế nào ạh.
 
Upvote 0
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!
 
Upvote 0
ndu96081631 đã viết:
Gì vậy?
Xem video clip này nhé:
Đổi tên bình thường mà
Nhấp chuột vào đây để mở rộng...

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
 
Lần chỉnh sửa cuối:
Upvote 0
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?
Nhấp chuột vào đây để mở rộng...

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
 
Upvote 0
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 ạ?
 
Lần chỉnh sửa cuối:
Upvote 0
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 ạ?
Nhấp chuột vào đây để mở rộng...
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???
 
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

doandat92
Tách chữ in đậm
Trả lời
7
Đọc
10
Hoàng Tuấn 868
H
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
4
Đọc
63
thaiquy7
T
ann266
Kế toán kho F&B
    • Cười
Trả lời
11
Đọc
121
doandat92
doandat92
senna
  • Question
Xin giúp đỡ tổng hợp dữ liệu từ nhiều file vào 1 file mà không cần mở file
Trả lời
0
Đọc
20
senna
senna
V
  • Question
GIúp code xóa các tên mặt hàng trùng nhau, chỉ chừa lại tên cho dòng trên cùng
Trả lời
10
Đọc
295
Phan Thế Hiệp
Phan Thế Hiệp
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

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