Trợ giúp về hàm auto insert picture (1 người xem)

[chiphoi3]

Chào tất cả mọi người,

Mình mới tham gia diễn đàn GPE, vấn đề của mình liên quan đến việc tự động insert hình ảnh cá nhân của nhân sự trong công ty. Mình đã dùng chức năng search của diễn dàn và thấy có 1 số topic cũng liên quan đến vấn đề này nhưng chưa hoàn thiện, nay mình xin mở topic nhờ các anh chị có kinh nghiệm trợ giúp.

Các topic liên quan:

http://www.giaiphapexcel.com/forum/showthread.php?t=25440
http://www.giaiphapexcel.com/forum/showthread.php?p=131046
http://www.giaiphapexcel.com/forum/showthread.php?t=4669

Mình tổng hợp lại vấn đề như sau:
- Chức năng insert picture sẽ được tự động dựa trên đường dẫn có sẵn
- Nếu thay đổi đường dẫn thì hình cũ sẽ được xóa đi, và hình mới sẽ được cập nhật
- Có thể dùng chức năng Fill handle (giống như fill down khi dùng chuột kéo xuống như trong hình). Vấn đề này mình chưa thấy đoạn mã nào trong GPE giải quyết được nếu như dữ liệu khá nhiều (bị duplicate hình), ko thể manual insert ID cho từng cell được. Đây cũng chính là vấn đề lớn nhất của mình

- Vị trí của hình khi insert linh động (trong ví dụ của mình thì mình muốn nó gắn vào column C)
- Hình ở vị trí center của cell (đối với cell quá lớn mà hình quá nhỏ)
hoặc tự động resize hình theo kích thước mặc định của cell
- Đường dẫn thư mục hình ảnh linh hoạt (không nhất thiết phải nằm cùng 1 thư mục với file excel)
- Sau khi insert hình thì có thể xóa đường dẫn đi mà ko bị mất hình
- Hình ảnh được attach thẳng vào file excel và có thể share cho người khác mà ko cần các file hình ảnh đi kèm (vì file hình ảnh nằm rải rác các folder khác nhau như ví dụ hình trên)

Mình cũng có search google hy vọng kiếm 1 cái function dạng user-defined giải quyết vấn đề này nhưng vẫn chưa tìm ra.
Mình đính kèm file data mẫu, hy vọng các cao thủ của GPE giúp mình.
Thân.

 

[vuongtoituonglai]

Xin lỗi bác Siwtom, em chen ngang vào 1 chút (Vì hơi hướng nhiệt đọ còn cao hay sao ấy...)

Đối với hàm này, để có thể load ảnh thì phải chỉ rõ file đó là file nào,đuôi gì, nằm ở đâu?
Phân tích câu lệnh sau:

ThisWorkbook.Path & "\" & picname & ".jpg"

Đoạn màu đỏ cho vị trí ở đâu. Ví dụ: "D:\Cac file GPE\"
Đoạn màu xanh cho tên file. Ví dụ "Hong001"
Đoạn màu nâu cho biết dạng file (Đuôi mở rộng) Ví dụ:".jpg"

Gộp lại ta được:

"D:\Cac file GPE\Hong001.jpg"
Function InsertPic(ByVal picname As String) As StringDim fullName As String, pic As Shape, cell_ As range, fs As ObjectDim mPath as stringmPath=Thisworkbook.worksheets(“Sheet1”).[D1].Value Set cell_ = Application.ThisCell On Error Resume Next cell_.Parent.Shapes(cell_.Address).Delete If Err.Number Then Err.Clear On Error GoTo 0 Set fs = CreateObject("Scripting.FileSystemObject") If fs.FileExists(mPath & picname & ".jpg") Then fullName = picname & ".jpg" ElseIf fs.FileExists(mPath & picname & ".bmp") Then fullName = picname & ".bmp" End If If fullName <> "" Then Set pic = cell_.Parent.Shapes.AddPicture(mPath & fullName, _ msoFalse, msoTrue, cell_.left, cell_.top, cell_.Width, cell_.Height) pic.LockAspectRatio = msoTrue pic.Name = cell_.Address End If Set cell_ = Nothing Set fs = NothingEnd Function
Tóm lại là cung cấp 1 chuỗi nêu đủ đường dẫn-Tên file-Loại file
Giờ bạn muốn thay đường dẫn đến vị trí khác thì bạn phải báo cho nó biết thay vì lấy theo ThisWorkbook.Path l chẳng hạn bạn ghi đường dẫn tại ô D1 trên Sheet1="D:\Cac file GPE\". Giờ bạn sửa Code như sau là ổn

Function InsertPic(ByVal picname As String) As String
Dim fullName As String, pic As Shape, cell_ As range, fs As Object
Dim mPath as string
mPath=Thisworkbook.worksheets(“Sheet1”).[D1].Value
    Set cell_ = Application.ThisCell 
   On Error Resume Next
    cell_.Parent.Shapes(cell_.Address).Delete 
   If Err.Number Then Err.Clear
    On Error GoTo 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists(mPath & picname & ".jpg") Then  
      fullName = picname & ".jpg"  
  ElseIf fs.FileExists(mPath & picname & ".bmp") Then 
       fullName = picname & ".bmp" 
   End If 
   If fullName <> "" Then
        Set pic = cell_.Parent.Shapes.AddPicture(mPath & fullName, _ 
           msoFalse, msoTrue, cell_.left, cell_.top, cell_.Width, cell_.Height) 
       pic.LockAspectRatio = msoTrue
        pic.Name = cell_.Address
    End If 
   Set cell_ = Nothing
    Set fs = Nothing
End Function

Bạn truyền đường dẫn cho Hàm qua biến mPath (Bạn cũng có thể khai thẳng trong Hàm bằng cách thay đoạn

mPath=Thisworkbook.worksheets(“Sheet1”).[D1].Value
Thành:
mPath="D:\Cac file GPE\")

(Không biết có đúng câu hỏi không nữa đây?)

Mình đang lờ mờ với đoạn code không biết phải sửa như thế nào để chạy được.
File hình của mình nằm ở đường dẫn: Y:\My Picture\Staff
File excel của mình nằm ở đường dẫn: Z:\So do cong doan\L01
Bạn xem chỉ lại dùm mình nhé.

 

[sealand]

Không quan tâm file Excel nằm ở đâu, để tìm hiểu thì bạn lưu ý các đoạn màu đỏ. Code này bạn cứ chép vào là chạy.

Function InsertPic(ByVal picname As String) As String
Dim fullName As String, pic As Shape, cell_ As range, fs As Object
[COLOR=#ff0000]Dim mPath as string
mPath="Y:\My Picture\Staff\"
[/COLOR]    Set cell_ = Application.ThisCell 
   On Error Resume Next
    cell_.Parent.Shapes(cell_.Address).Delete 
   If Err.Number Then Err.Clear
    On Error GoTo 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists([COLOR=#ff0000]mPath & picname & ".jpg"[/COLOR]) Then  
      [COLOR=#ff0000]fullName = picname & ".jpg"[/COLOR]  
  ElseIf fs.FileExists([COLOR=#ff0000]mPath & picname & ".bmp"[/COLOR]) Then 
       [COLOR=#ff0000]fullName = picname & ".bmp"[/COLOR] 
   End If 
   If [COLOR=#ff0000]fullName <> ""[/COLOR] Then
        Set pic = cell_.Parent.Shapes.AddPicture([COLOR=#ff0000]mPath & fullName[/COLOR], _ 
           msoFalse, msoTrue, cell_.left, cell_.top, cell_.Width, cell_.Height) 
       pic.LockAspectRatio = msoTrue
        pic.Name = cell_.Address
    End If 
   Set cell_ = Nothing
    Set fs = Nothing
End Function

 

[vuongtoituonglai]

Không quan tâm file Excel nằm ở đâu, để tìm hiểu thì bạn lưu ý các đoạn màu đỏ. Code này bạn cứ chép vào là chạy.

Function InsertPic(ByVal picname As String) As String
Dim fullName As String, pic As Shape, cell_ As range, fs As Object
[COLOR=#ff0000]Dim mPath as strin654g
mPath="Y:\My Picture\Staff\"
[/COLOR]    Set cell_ = Application.ThisCell 
   On Error Resume Next
    cell_.Parent.Shapes(cell_.Address).Delete 
   If Err.Number Then Err.Clear
    On Error GoTo 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists([COLOR=#ff0000]mPath & picname & ".jpg"[/COLOR]) Then  
      [COLOR=#ff0000]fullName = picname & ".jpg"[/COLOR]  
  ElseIf fs.FileExists([COLOR=#ff0000]mPath & picname & ".bmp"[/COLOR]) Then 
       [COLOR=#ff0000]fullName = picname & ".bmp"[/COLOR] 
   End If 
   If [COLOR=#ff0000]fullName <> ""[/COLOR] Then
        Set pic = cell_.Parent.Shapes.AddPicture([COLOR=#ff0000]mPath & fullName[/COLOR], _ 
           msoFalse, msoTrue, cell_.left, cell_.top, cell_.Width, cell_.Height) 
       pic.LockAspectRatio = msoTrue
        pic.Name = cell_.Address
    End If 
   Set cell_ = Nothing
    Set fs = Nothing
End Function

Cảm ơn bạn nhé. Mình làm được rồi.

 

[Thuonghttt]

Không quan tâm file Excel nằm ở đâu, để tìm hiểu thì bạn lưu ý các đoạn màu đỏ. Code này bạn cứ chép vào là chạy.

Function InsertPic(ByVal picname As String) As String
Dim fullName As String, pic As Shape, cell_ As range, fs As Object
[COLOR=#ff0000]Dim mPath as string
mPath="Y:\My Picture\Staff\"
[/COLOR]    Set cell_ = Application.ThisCell 
   On Error Resume Next
    cell_.Parent.Shapes(cell_.Address).Delete 
   If Err.Number Then Err.Clear
    On Error GoTo 0
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists([COLOR=#ff0000]mPath & picname & ".jpg"[/COLOR]) Then  
      [COLOR=#ff0000]fullName = picname & ".jpg"[/COLOR]  
  ElseIf fs.FileExists([COLOR=#ff0000]mPath & picname & ".bmp"[/COLOR]) Then 
       [COLOR=#ff0000]fullName = picname & ".bmp"[/COLOR] 
   End If 
   If [COLOR=#ff0000]fullName <> ""[/COLOR] Then
        Set pic = cell_.Parent.Shapes.AddPicture([COLOR=#ff0000]mPath & fullName[/COLOR], _ 
           msoFalse, msoTrue, cell_.left, cell_.top, cell_.Width, cell_.Height) 
       pic.LockAspectRatio = msoTrue
        pic.Name = cell_.Address
    End If 
   Set cell_ = Nothing
    Set fs = Nothing
End Function

Anh ơi e mới học vba e làm theo code của anh mà sau khi ghi hàm xong nó chỉ trả về giá trị #name chứ k thấy có hình gì hết là bị làm sao ạ