Thêm 1 dạng PicForm

Chia sẻ bởi:hands

★★★★★

‹ Chèn hình ảnh tự động vào excel Chèn hình vào cell bằng hàm tự... ›

Quảng cáo

Tôi thấy lúc trước trên diển đàn có tác giả làm PicForm dựa vào Comment… Và đây lại là dạng khác của PicForm, mời các bạn tham khảo.
Khi xưa ta bé ta ngu…
Ngày trước download file này ở các trang nước ngoài về, chỉ đơn giản thấy hay thì đưa lên… giờ xem lại code thấy.. buồn cười (code dài dòng, lúc chạy thì cà giật) ===> đâu cứ code nước ngoài viết là hay
He… he…
Sửa lại đây

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim mySel As Range
On Error Resume Next
If Not Intersect(Range("KeyCells"), Target) Is Nothing Then
Set mySel = Selection
ActiveSheet.Shapes(mySel.Address & "Final").Delete
ActiveSheet.Shapes(mySel.Value).Copy
With mySel
.Offset(0, 2).PasteSpecial
Selection.Name = .Address & "Final"
Selection.Left = .Offset(0, 2).Left: Selection.Top = .Offset(0, 2).Top
Selection.Width = .Offset(0, 2).Width: Selection.Height = .Offset(0, 2).Height
End With
End If
mySel.Select
End Sub
File này dùng 3 hình mẫu có sẳn trong sheet, các bạn có thể cải tiến, thậm chí không cần mấy hình mẩu này tôi nghĩ cũng ko có vấn đề (nếu trong máy tính của ta đã có sẳn)
(Record quá trình Insert hình rồi chỉnh lại code).
Lại tiếp tục cải tiến:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim PicRng As Range, Pos As String
Application.ScreenUpdating = False
On Error Resume Next
If Not Intersect(, Target) Is Nothing Then
Set PicRng = Range("G1").CurrentRegion '<— Dat ten cho vung tra cuu hinh
Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<— Xac dinh vi trí chua file hinh tren PC
ActiveSheet.Shapes(Target.Address).Delete '<— Xoa hinh da dat ten truoc do
With ActiveSheet.Pictures.Insert(Pos) '<— Chen hinh moi
.Name = Target.Address '<— Dat ten cho hinh moi chính là dia chi cell
.Left = Target(1, 0).Left: .Top = Target(1, 0).Top '<— Dinh vi cho hinh
.Width = Target(1, 0).Width: .Height = Target(1, 0).Height '<— Dinh chieu rong, cao cho hinh
End With
End If
Application.ScreenUpdating = True
End Sub
Bỏ luôn mấy hình mẩu (lấy hình dựa vào đường dẩn)
Các bạn có thể dựa vào file này để làm PicForm (khá đơn giãn)
ANH TUẤN

www.giaiphapexcel.com/diendan/threads/th%C3%AAm-1-d%E1%BA%A1ng-picform.3721/#post536728

Khóa học SprinGO phù hợp

Ứng dụng AI và Chat GPT trong Quản trị nhân sự

Học xong khóa này, học viên có thể: Hiểu đúng bản chất AI, các nhóm AI phổ biến và cách AI “hoạt động” ở...

Xem khóa học

★★★★★ 5 ★ 1 👤 8 ▥ 0

‹ Chèn hình ảnh tự động vào excel Chèn hình vào cell bằng hàm tự tạo ›

Quảng cáo

Bạn nên đọc

8 Responses

hands says:

23/12/2022 at 10:36 am

Làm sao để thêm được hình khác theo bài này nữa vậy bạn @

Bạn cho toàn bộ code này vào sheet nhé:
```
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim pic As Picture
  On Error Resume Next
  If Not Intersect(Range("B5:B10"), Target) Is Nothing Then
    If Target.Count = 1 Then
      With Target.Parent
        .Pictures(Target.Address).Delete
        Set pic = .Pictures(Target.Value)
      End With
      If Not pic Is Nothing Then
        pic.Copy
        Target.Offset(, 2).PasteSpecial
        With Selection
          .Name = Target.Address
          .ShapeRange.LockAspectRatio = msoFalse
          .Left = Target.Offset(, 2).Left: .Top = Target.Offset(, 2).Top
          .Width = Target.Offset(, 2).Width: .Height = Target.Offset(, 2).Height
        End With
      End If
    End If
  End If
  Target.Select
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim rCel As Range, pic As Picture, arr(), n As Long
  On Error Resume Next
  If Not Intersect(Range("B5:B10"), Target) Is Nothing Then
    If Target.Count = 1 Then
      For Each pic In Target.Parent.Pictures
        If Not (pic.Name Like "$*$*") Then
          n = n + 1
          ReDim Preserve arr(1 To n)
          arr(n) = pic.Name
        End If
      Next
      If IsArray(arr) Then
        With Target.Validation
          .Delete
          .Add 3, , , Join(arr, ",")
        End With
      End If
    End If
  End If
End Sub
```
Khi bạn thêm bất cứ hình nào vào bảng tính thì validation cũng cập nhật
(Vùng chọn Validation là B5:B10)

Cám ơn thày Anh tuấn ! thày cho hỏi liệu có thể phóng to ảnh lên vài lần khi rê chuột đến được không ? vì như thế dữ liệu dòng và cột chỉ cần nhỏ thôi . Khi cần xem ảnh ta rê chuột vào ảnh được phóng to để cho dễ nhìn .

Rê chuột vào để phóng to thì khó. Ta có thể thay bằng: Click chuột vào ảnh để phóng to <— Cái này quá dễ, record macro quá trình thay đổi size hình để có code

Thay cho toàn bộ code cũ hả bạn ???

Chính xác là thế! Nếu không, chẳng lẽ có 2 code sự kiện Change trong cùng 1 sheet sao? Nó báo lỗi liền

Có lẽ nhà em hỏi chưa chuẩn thì đúng hơn, không phải "Rê chuột" đến , mà là "di chuyển chuột đến" thì hình tự động phóng to, khi chuột di chuyển đến ô khác thì nó trở lại trạng thái cũ .

Rê chuột đến hay di chuyển chuột đến thì cũng như nhau thôi. Tóm lại: Picture không có sự kiện này
Ta chỉ có thể điều khiển hình phóng to, thu nhỏ khi ta dùng chuột CLICK VÀO HÌNH thôi

Điều nữa là thày có thể kết hợp lấy hyferlink ảnh tự động luôn thì tốt quá vì hyferlink thủ công , nếu nhiều ảnh thì cũng khá vất. Xin cám ơn thày .

Hyperlink ảnh tự động nghĩa là sao?
Hyperlink theo tôi hiểu nghĩa là CLICK VÀO NÓ SẼ DI CHUYỂN ĐẾN NƠI KHÁC (đến bảng tính khác, đến file khác hoặc 1 trang web)
Vậy nên bạn nói Hyperlink ảnh tự động tôi cũng chẳng hiểu công việc ấy là gì nữa
Hay bạn muốn rằng: Khi chọn Validation thì ảnh tự động insert mà không cần phải insert trước đó? Nếu là vậy thì đây là bài toán khác hoàn toàn. Đã có trên GPE rồi đấy thôi:
https://www.giaiphapexcel.com/forum/showthread.php?51408-Ch%C3%A8n-h%C3%ACnh-v%C3%A0o-cell-b%E1%BA%B1ng-h%C3%A0m-t%E1%BB%B1-t%E1%BA%A1o

Xin lỗi thày, vì link của ảnh mầu xanh nên nhà em tưởng phải Hyperlink đến file ảnh . Nói để diến đạt chính xác thật khó, nhà em đính kèm tập tin nhờ thày giúp . code phóng to, thu nhỏ nhà em làm rồi, nó hoạt động tốt, nhưng nhà em loay hoay mãi để nó tự động thực hiện khi di chuyển chuột đến các ô có chứa địa chỉ ảnh mà không được. Mong thày xem giúp vì nhà em trình độ VBA kiểu ăn đong nên khó quá . Không phải ta cần sự kiện của ảnh mà là của cell thày ạ, tức là sự kiện để chạy 2 sub trên,làm sao để đia chỉ trong code thay đổi theo chuột là được . Không biết ý tưởng của nhà em thế có được không nữa ? Nghe có vẻ kỳ kỳ , mong thay xem giúp và hồi âm . Biết thày không thích gọi là "Thày", nhưng 1 ngày là thày mà 1 chữ cũng là thày mà . Vả lại học thày bao nhiêu là chữ .

Yêu cầu của bạn nếu làm thật kỹ cũng không phải dễ dàng gì
Bạn xem file đính kèm và test thử nha
(code quá trời luôn!)

Cám ơn thày! Đúng là code quá trởi luôn . Thày viết code như nhà em viết chính tả , khiếp thật . Nếu nhà em chép lại lượng code vậy chắc chưa xong . Nhà nhà em đã text thử , nói chung code lấy ảnh và compic ảnh chay tốt , riêng code ShpResize và chỉ thấy chớp màn hình và ảnh chỉ lướt qua rồi tắt . Theo em, hình như code làm việc tôt, chỉ thiếu câu lệnh gì đó . Về nguyên tắc là khi chạy code ShpResize thì ảnh đựợc phóng to, sau khi xem ảnh , chỉ sau khi di chuyển trỏ sang cell khác thì code trở về trạng thái cũ mới chạy , thày kiểm tra giúp nhà em với ạ . theo cái kiến thức con con của mình, nhà em cảm thấy thế không biết có phải không , thày thông cảm .

Quên dặn bạn:
– Đừng bấm Alt + F8, chọn Sub để chạy gì cả
– Code được thiết kế tự động hóa hoàn toàn: Click chuột vào hình sẽ phóng to, click lần nữa sẽ thu nhỏ. Hoặc ta click chuột ra khỏi hình (chọn 1 cell nào đó) thì hình cũng sẽ được reset
– Khi chon Validation, nếu đường dẫn tại cell F1 không chưa hình nào (tức file không tồn tại) thì lập tức cửa sổ chọn Folder sẽ hiện ra cho bạn chọn lại thư mục chứa hình
– Bạn cũng có thể chủ động bấm vào nút Select Folder để chọn đường dẫn
vân vân… Từ từ khám khá nha. Code tren vẫn chưa được hay đâu (tại viết hơi vội)
Ngoài ra: Tôi dùng Excel 2010 nên không chắc trên Excel 2003 sẽ chạy thế nào

Cám ơn thày! Do thấy tập tin đuôi .xls nên nhà em mở bằng Excel 2003 nên nó sinh lỗi vậy . Nhà em mở bằng Excel 2010 tốt rồi ạ, cám ơn thày .
Cám ơn thày ! Nhà em đã text thử code chạy tốt trên excel 2010, nhưng hiện nhà em muốn thày giúp thêm chút nữa là :
– Chẳng hạn khi chọn folder ảnh thì ảnh tự động chèn vào các ô theo số lượng ảnh trong folder đó . Khi cần đổi ảnh thì mới chon list trong từng ô .

Tức là bạn muốn khi bấm nút Select Folder thì ảnh chèn luôn?
Vậy sửa SelectFolder thành:
```
Sub SelectFolder()
  Dim arr, vFolder, [COLOR=#ff0000]pic, Target As Range
  Dim lR As Long
  Dim PicPath As String[/COLOR]
  On Error Resume Next
  vFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 1).Self.Path
  If TypeName(vFolder) = "String" Then
    If Right(vFolder, 1) <> "" Then vFolder = vFolder & ""
    arr = FilesFoldersList(vFolder, True, "*.jpg", False)
    If IsArray(arr) Then
      aFiles = arr
      sFolder = CStr(vFolder)
      Range("F1") = sFolder
[COLOR=#ff0000]      For Each pic In arr
        PicPath = sFolder & CStr(pic)
        InsertPic PicPath, Target, "ShpResize"
        Set Target = Range("A5").Offset(lR)
        lR = lR + 1
      Next[/COLOR]
      Range("F1").Select
    End If
  End If
End Sub
```
Đồng thời thêm 1 Sub nữa:
```
Sub InsertPic(ByVal PicPath As String, ByVal Target As Range, Optional ByVal Action As String = "")
  On Error Resume Next
  Target.Parent.Pictures(Target.Address).Delete
  With Target.Parent.Pictures.Insert(PicPath)
    .Name = Target.Address
    .ShapeRange.LockAspectRatio = msoFalse
    .Left = Target.Left: .Top = Target.Top
    .Width = Target.Width: .Height = Target.Height
    .OnAction = Action
  End With
End Sub
```
– Thày có thế sửa code để có thể chạy cả ở Excel 2003 được không ạ ? vì khi ta gửi dữ liệu cho người khác , họ sử dụng Excel 2003 thì code phóng to ảnh bị lỗi ạ ?
Mong hồi âm từ thày! Xin cám ơn thày !

Không phải là tôi cố tình viết cho Excel 2010 mà là vì tôi không có bản Office 2003 để test nên không biết được lỗi phát sinh từ đâu
Nếu bạn dùng Excel 2003, để tìm lỗi, hãy bỏ mấy dòng On Error Resume Next rồi test xem khi lỗi xuất hiện nó đánh dấu vàng tại vị trí nào. Từ đó ta mới đoán bệnh được

Không phải là tôi cố tình viết cho Excel 2010 mà là vì tôi không có bản Office 2003 để test nên không biết được lỗi phát sinh từ đâu
Nếu bạn dùng Excel 2003, để tìm lỗi, hãy bỏ mấy dòng On Error Resume Next rồi test xem khi lỗi xuất hiện nó đánh dấu vàng tại vị trí nào. Từ đó ta mới đoán bệnh được

***
```
Sub ShpResize()
  Dim pic As Picture
  Dim bMark As Boolean
[COLOR=#0000ff][B]   Set pic = Sheet1.Pictures(Application.Caller)[/B][/COLOR]
  With pic.ShapeRange
    bMark = (Len(.AlternativeText) > 0)
    If bMark = False Then
      .ScaleWidth 5, msoFalse, msoScaleFromMiddle
      .ScaleHeight 5, msoFalse, msoScaleFromMiddle
      .AlternativeText = "TRUE"
      .ZOrder msoBringToFront
    Else
      .Left = Range(.Name).Left: .Top = Range(.Name).Top
      .Width = Range(.Name).Width: .Height = Range(.Name).Height
      .AlternativeText = vbNullString
    End If
  End With
End Sub
```
Cám ơn thày ! Nó báo lỗi tại dòng màu xanh đậm trên ạ !

Reply
hands says:

23/12/2022 at 10:38 am

Lỗi này chỉ có thể có khi: Bạn chạy trực tiếp sub trên bằng cách Alt + F8 để chọn Sub thay vì click vào hình
Còn lại, Application.Caller chẳng liên quan gì đến version của office cả (Excel 2003 cũng dùng được)

Xin lỗi thày, giờ nhà em mới vào mạng được . Tình hình cụ thể thế này ạ .
Sau khi xóa dòng lệnh "on Error resume next" và click vào hình thì nó xuất hiện hộp thông báo lỗi :
'Run-time Error 1004'
Methot 'Pictures' of object '_Worksheet' Failed
và 4 nút . Nút Continue mờ và 3 nút End và Debug và Help . Click vào nút Debug thì xuất hiện code và dòng lệnh trên bị bôi vàng ạ!

Bạn có để ý thấy trong file của bạn tuy nhìn thấy 5 hình nhưng thực chất là 10 hình không?
Tức là: 5 hình nằm dưới 5 hình
Kiểm tra lại xem
(như vậy làm sao mà code chạy được: Vì 2 hình trùng tên)
Nhưng với Excel 2003 cũng bị lỗi! Bạn sửa lại code như sau:
```
Sub ShpResize()
[COLOR=#ff0000][B]  Dim pic As Shape[/B][/COLOR]
  Dim bMark As Boolean
[B][COLOR=#ff0000]  Set pic = ActiveSheet.Shapes(Application.Caller)[/COLOR][/B]
[COLOR=#ff0000][B]  With pic[/B][/COLOR]
    bMark = (Len(.AlternativeText) > 0)
    If bMark = False Then
      .ScaleWidth 5, msoFalse, msoScaleFromMiddle
      .ScaleHeight 5, msoFalse, msoScaleFromMiddle
      .AlternativeText = "TRUE"
      .ZOrder msoBringToFront
    Else
      .Left = Range(.Name).Left: .Top = Range(.Name).Top
      .Width = Range(.Name).Width: .Height = Range(.Name).Height
[COLOR=#ff0000][B]      .AlternativeText = ""[/B][/COLOR]
    End If
  End With
End Sub
```
Rồi, bây giờ bạn có thể click 1 lần cho nó bự ra, rồi click một lần nữa nó thu lại!
Excel 2003 và 2007 sẽ khó phát hiện vụ này
Excel 2010 chỉ cần Alt + F10 sẽ thấy liền
————
Mà cũng không hiểu tại sao lại có cái vụ trùng hình vầy nữa? Code ở trên người ta đã tính cả rồi: Chèn hình mới là lập tức xóa hình cũ trước đó. Vậy mà cũng có vụ trùng, chẳng biết ở đâu ra nữa

Nhà em đã kiểm tra lại đúng là 10 hình nhưng do lúc đầu load ảnh từ Folder nó nhỏ quá, nhà em nghĩ nó xóa ảnh cũ nạp ảnh mới, nên cư thế gọi sub . Nhưng nó cứ thế nạp ảnh mới nên thành 10 ảnh . Nhưng kiểm tra và chạy lại vẫn lỗi trên thày ạ . Hay còn chức năng nào cần phải kích hoạt không nhỉ ? Nhà em gửi tiếp File đính kèm tiếp, thật phiền các thày quá .

Cám ơn sự nhiệt tình của các thày, nhà em sợ các thày chờ nên hơi vội , chậm tý nữa thì không phải post bài nữa . Code của thày Nghĩa chạy rồi ạ . Nhờ thày NDU xóa hộ bài trên với chức năng smod ạ . Nhanh nhảu đoảng quá ! cám ơn các thày . Còn vụ trùng hình chắc do gọi code 2 lần, Nhưng đáng ra nó phải xóa thì mới đúng .

Thày Nghĩa xem giúp code trên chạy không ổn định . Lúc nó trả lại kích thước ban đầu của ảnh, lúc nó lại tạo thêm ảnh khi Click vào nó . Một điều nữa là toàn bộ List để đổi ảnh tại cột B đều mất hết . Thày cố gắng giúp nhà em code chạy ổn định như code của thày NDU chạy trên Excel 2010 là được . Mà kỳ lạ là nhiều code chạy trên Excel 2010 ghi sang đuôi xls chạy bình thường . Lần này nó bắt nạt nhà em ghê quá , ước gì "bụt" hiện lên để nhà em ước mình giỏi Excel để nó khỏi bắt nạt . Thôi thì học dần vậy .Thày NDU bỏ hẳn cái vụ Excel 2003 rồi, tiêc thật . Riêng cái vụ office 2007 trở đi nó có bộ mặt khác, chức năng khác , bước chuyển tiếp quá dài khiến nhiều người chóng mặt không theo kịp nên cứ tụt lại sau chịu tiếng là lạc hậu .

Muốn gỡ xuống cái file thì bạn bấm sửa, Đổi sang khung lớn, chọn Tải file từ máy, tại đây bạn thấy cái file của bạn rồi bấm Remove thôi!

==========================

Cái file của bạn đã được chỉnh sửa, giờ bạn tự check lại xem còn lỗi không, giờ làm biếng test quá!

Cám ơn thày ! Không được rồi thày ơi! 5 cái ảnh cũ thì được nhưng nạp ảnh mới nó lại lỗi vậy .

Tại Sub InsertPic, bạn thay câu lệnh này:
```
Target.Parent.Pictures(Target.Address).Delete
```
Thành câu lệnh này thử xem sao!
```
ActiveSheet.Shapes(Target.Address).Delete
```
Target.Parent với ActiveSheet là mấy thứ trời?
Ngoài lề 1 chút: Không biết bạn nào có bộ Office 2003 Portable có thể chạy được trên Win7 và dùng được VBA không? Nếu có cho tôi xin link với
Bảo đảm có bộ office 2003, tôi test code 1 phát là biết liền lỗi ở đâu ngay

Nhưng quan trọng là Excel 2003 nó chịu với Shapes mà nó không chịu với Pictures mới đau!

Nói thật nha: Cái này TÔI KHÔNG TIN!
Vì cái vụ Pictures này trước đây tôi đã từng xài (khi còn dùng WinXP + Office 2003)

Em kiểm tra kỹ rồi, ai không tin thì cứ thử thôi. Excel 2007 trở về sau mới sử dụng được với nó!

Và để chắc chắn nhất, cứ hỏi bạn Ngoai Thanh về vấn đề này mà sau khi em đã sửa code là biết liền!

Reply
hands says:

23/12/2022 at 10:40 am

Em kiểm tra kỹ rồi, ai không tin thì cứ thử thôi. Excel 2007 trở về sau mới sử dụng được với nó!

VÔ LÝ!
Thế chẳng lẽ Excel 2003 ta không Insert được Picture?
Vậy thì dòng code ActiveSheet.Pictures.Insert(FileName) chẳng đã dùng từ đởi office nào rồi sao?
Đó không phải là Picture và Pictures object thì gọi là gì?

Cám ơn thày, nhà em có đĩa office 2003 nhưng dung lượng riêng nó đến 400 Mb nên không biết có cách gì để gửi không ạ ?
Cám ơn thày, nhà em đã text thử, không thây nó báo lỗi nhưng chậm hơn và list để đổi ảnh tại cột B lại không còn. không biết sao nữa , làm các thày vất vả , nhà em ngại quá .

Gì mà ngại chứ bạn!
Luôn luôn giúp đở và chia sẻ kiến thức với mọi người trong khả năng có thể <— Đó là tiêu chí của tôi
Để mai tìm máy tính khác test thử xem (trên Excel 2003)
Mình đành.. bó tay rồi
Tìm khắp cty cũng chẳng có máy nào còn xài Office 2003. Lượm được 1 bộ Potable Office 2003, mừng quá test 1 phát thì… ôi thôi, nó chẳng hổ trợ VBA
Thời buổi này còn xài Office 2003 rõ khổ (vì sẽ nhận được ít sự trợ giúp)

Thầy qua Cơ quan em! Office 2000 cũng còn nhiều lắm ạ! Win 98, Win Me vẫn còn vài máy nữa đó! Nhà nước tiết kiệm muôn năm mà!

Cám ơn thày ! Nói như thày Nghĩa đúng đấy ạ . Các cơ quan xí nghiệp còn nhiều nơi và nhiều người còn đang dùng Win xp và office 2003 và được coi là "cơ bản", Win 7, Win 8 và office 2010 , 2013 là "vẽ vời" . Vì đa số còn đang dùng nên người ta không thấy bị lạc hậu . Nói thày đừng cười, có lúc gửi dữ liệu , họ nhận được gọi điện lại " Dữ liệu kiểu gì vậy, xem được quái đâu? gửi lại đi, không biết làm Excel à ?" . Vậy đó thày . Nhưng họ là A nên chịu , thì ghi sang đuôi .xls rồi gửi đi , gọi điện hỏi lại , họ bảo "lần sau cứ thế mà làm , bực cả minh !" .Đặc biệt dữ liệu có hỗ trợ VBA có khi còn không được chấp nhận vì họ không kiểm tra được Kết quả, công thức tính thế nào ( từ đâu đến đâu, bằng cái gì + – * / với cái gì ). Cũng có người , sau khi được hướng dẫn, dùng thử thú nhận : Hay đấy ! nhưng vẫn phải làm lại vì có phải mình tớ xem đâu . Thế đấy thày ạ !

Xài cái gì là tùy theo sở thích và quan điểm của cá nhân hoặc tổ chức
Có điều các bạn cũng thấy trên mạng giờ người ta xài đến Office 2013 (thậm chí là 64bit). Mình còn "lẹt đẹt" tận đâu thì… có trục trặc gì tự mò vậy

Nói thày đừng cười, có lúc gửi dữ liệu , họ nhận được gọi điện lại " Dữ liệu kiểu gì vậy, xem được quái đâu? gửi lại đi, không biết làm Excel à ?" . Vậy đó thày . Nhưng họ là A nên chịu , thì ghi sang đuôi .xls rồi gửi đi , gọi điện hỏi lại , họ bảo "lần sau cứ thế mà làm , bực cả minh !"

Nếu là một đối tác nước ngoài gửi cho file XLSX, XLSM, thậm chí là có code VBA bên trong thì chắc họ (hoặc sếp của họ) đã không nói vậy rồi.
Lúc đó họ (hoặc sếp họ) phải làm sao nhỉ? Suy nghĩ xem!

Họ gọi người thuê thôi ! và đặc biệt là họ thấy thế là bình thường . chẳng khác gì tài liệu tiếng nước ngoài: thuê dịch, thế là xong . Không làm được thì thuê ! thật là đơn giản . Do thày làm với người nước ngoài nhiều nên thấy "chướng" chứ nhiều người cả đời không quan hệ với đối tác là người nước ngoài, trừ khi dùng tiền "chùa" đi du lịch thì đã có phiên dịch thì họ lo gì . OK mà thày . Cái đáng sợ là họ thấy đó là điều tất nhiên !

Tính mình rất hiếu kỳ. Mỗi khi gặp 1 vấn đề hơi "lạ lạ" là phải nhất định tìm hiểu tận gốc mới thôi
Trường hợp của bạn mình suy nghĩ mãi cũng không thấy có vấn đề gì. Ngoại trừ dòng lệnh LockAspectRatio = msoFalse không dùng được trên Excel 2003 thì các code còn lại là hoàn toàn tương thích
Tuy nhiên, để chắc ăn thì phải test trực tiếp… Cũng đã cố tìm máy nào đó có Office 2003 mà đành.. bó bột thôi
Ẹc… Ẹc… Tóm lại là: thua
(Để vài bữa hỏi thử xem ai có bộ Potable Office có hổ trợ VBA sẽ tính tiếp)

Vâng , cám ơn thày ! Nhà em cũng vậy, cái gì bây giờ chưa làm được thì sau này có điều kiện lại làm . Có việc mấy năm sau tự nhiên sực nhớ đến, khi làm được rồi , lắm lúc ngồi cười một mình . Thực ra cái này Thày Nghĩa tìm ra cái lỗi cơ bản rồi , chắc chạy trên Excel 2003 nên nó hơi chậm, Có khi nhà em tả có thể thày cũng biết nó lỗi cái gì : Tức là có lúc nếu nó xóa được ảnh khi ta kích vào sau khi phóng to, thi nó chạy tiếp bình thường . Còn không nó phóng to liên tiếp các ảnh khác khi ta kích vào và không thu nhỏ được nữa . Bây giờ sử lý được cái đó thì toàn bộ list và tên của ảnh nó không xuất hiện tại cột B nữa . Thực ra nhà em cũng muốn học các thày sử lý xem nó bị lỗi gì ? Ít ra ta cũng biết không phải lúc nào khi sử dụng Excel 2010 để ghi thành đuôi xls nó cũng chạy bình thường . Nếu lúc nào thày tìm ra lỗi,thày nhớ giúp nhà em với ! Hiện tại nhà em cứ làm trên Excel 2010 đã , khi có ai kêu nhà em tính sau . Xin cám ơn về sự uyên bác, xin cám ơn về sự tận tụy, xin cám ơn về sự nhiệt tình của thày .

Reply
hands says:

23/12/2022 at 10:41 am

Vâng , cám ơn thày ! Nhà em cũng vậy, cái gì bây giờ chưa làm được thì sau này có điều kiện lại làm . Có việc mấy năm sau tự nhiên sực nhớ đến, khi làm được rồi , lắm lúc ngồi cười một mình . Thực ra cái này Thày Nghĩa tìm ra cái lỗi cơ bản rồi , chắc chạy trên Excel 2003 nên nó hơi chậm, Có khi nhà em tả có thể thày cũng biết nó lỗi cái gì : Tức là có lúc nếu nó xóa được ảnh khi ta kích vào sau khi phóng to, thi nó chạy tiếp bình thường . Còn không nó phóng to liên tiếp các ảnh khác khi ta kích vào và không thu nhỏ được nữa . Bây giờ sử lý được cái đó thì toàn bộ list và tên của ảnh nó không xuất hiện tại cột B nữa . Thực ra nhà em cũng muốn học các thày sử lý xem nó bị lỗi gì ? Ít ra ta cũng biết không phải lúc nào khi sử dụng Excel 2010 để ghi thành đuôi xls nó cũng chạy bình thường . Nếu lúc nào thày tìm ra lỗi,thày nhớ giúp nhà em với ! Hiện tại nhà em cứ làm trên Excel 2010 đã , khi có ai kêu nhà em tính sau . Xin cám ơn về sự uyên bác, xin cám ơn về sự tận tụy, xin cám ơn về sự nhiệt tình của thày .

Chen ngang tí.

Trước hết góp ý về code trong bài #35 và #43
```
InsertPic PicPath, Target, "ShpResize"    <-- ([B][COLOR=#ff0000]A[/COLOR][/B])
        Set Target = Range("A5").Offset(lR)
        lR = lR + 1
```
Code trên không chuẩn. Ta xét vd. trong Folder có 2 ảnh. Khi thực hiện (A) cho ảnh đầu tiên thì Target = Nothing. Hậu quả là mọi dòng lệnh trong InsertPic đều sai. Do ta dùng "On Error Resume Next" để che "mụn nhọt" nên không thấy sai. Nhưng kết quả là ảnh 1 không được nhập vào đâu cả. Ảnh 2 sẽ được nhập vào A5.
Tóm lại nếu trong folder có 1 ảnh thì không có ảnh nào được load. Nếu có n ảnh thì chỉ có (n – 1) ảnh được load. Để khắc phục thì đổi thành
```
Set Target = Range("A5").Offset(lR)
        lR = lR + 1
        InsertPic PicPath, Target, "ShpResize"
```
Theo lôgic thì click lần đầu tiên vào ảnh thì ảnh phải phóng to vì ảnh hiện thời đang nhỏ. Nhưng với code hiện thời thì phải click lần thứ 2 thì ảnh mới to. Tức với mỗi ảnh ta tốn 1 click vô ích. Để khắc phục thì đổi code trong ShpResize
```
If bMark = False Then
         .ScaleWidth 5, msoFalse, msoScaleFromMiddle
...
         .AlternativeText = "TRUE"
    Else
         .AlternativeText = ""
    End If
```
thành
```
[COLOR=#ff0000]If bMark Then[/COLOR]
         .ScaleWidth 5, msoFalse, msoScaleFromMiddle
...
         [COLOR=#ff0000].AlternativeText = ""[/COLOR]
    Else

[COLOR=#ff0000].AlternativeText = "TRUE"[/COLOR]
    End If
```
—————
Vấn đề Pictures trên 2003 thì tôi không rõ vì có 2003 đâu để mà test. Nhưng nói cho cùng thì bạn muốn làm được việc chứ đâu phải lấy vợ mà bắt buộc phải "hoặc "em này" hoặc sẽ không em nào cả"?

Tóm lại, bạn không thấy là "cô" WorkSheet.Shapes.AddPicture vừa nết na, chăm làm, duyên dáng mà lại … ăn ít à?

http://www.giaiphapexcel.com/diendan/threads/th%C3%AAm-1-d%E1%BA%A1ng-picform.3721/post-535165

Reply
hands says:

23/12/2022 at 10:46 am
Tóm lại nếu trong folder có 1 ảnh thì không có ảnh nào được load. Nếu có n ảnh thì chỉ có (n – 1) ảnh được load. Để khắc phục thì đổi thành
```
Set Target = Range("A5").Offset(lR)
        lR = lR + 1
        InsertPic PicPath, Target, "ShpResize"
```
Chổ này thì đúng. Em sơ sót
Nhưng chổ này
Theo lôgic thì click lần đầu tiên vào ảnh thì ảnh phải phóng to vì ảnh hiện thời đang nhỏ. Nhưng với code hiện thời thì phải click lần thứ 2 thì ảnh mới to. Tức với mỗi ảnh ta tốn 1 click vô ích. Để khắc phục thì đổi code trong ShpResize
```
If bMark = False Then
         .ScaleWidth 5, msoFalse, msoScaleFromMiddle
...
         .AlternativeText = "TRUE"
    Else
         .AlternativeText = ""
    End If
```
thành
```
[COLOR=#ff0000]If bMark Then[/COLOR]
         .ScaleWidth 5, msoFalse, msoScaleFromMiddle
...
         [COLOR=#ff0000].AlternativeText = ""[/COLOR]
    Else

[COLOR=#ff0000].AlternativeText = "TRUE"[/COLOR]
    End If
```
Thì em nghĩ là sai! Lúc đầu AlternativeText chưa có gì, mà bMark = (Len(.AlternativeText) > 0) nên bMark sẽ =FALSE
Vậy nên xét điều kiện khi bMark=FALSE mới phóng to ảnh là chính xác rồi còn gì
Nếu sửa như anh thì click vào chẳng có chuyện gì xãy ra cả
Toàn bộ code của em viết là thế này:
```
Sub ShpResize()
  Dim pic As Picture
  Dim bMark As Boolean
  On Error Resume Next
  Set pic = Sheet1.Pictures(Application.Caller)
  With pic.ShapeRange
    [COLOR=#ff0000]bMark = (Len(.AlternativeText) > 0)[/COLOR]
    [COLOR=#ff0000]If bMark = False Then[/COLOR]
      .ScaleWidth 3, msoFalse, msoScaleFromMiddle
      .ScaleHeight 3, msoFalse, msoScaleFromMiddle
      .AlternativeText = "TRUE"
      .ZOrder msoBringToFront
    Else
      .Left = Range(.Name).Left: .Top = Range(.Name).Top
      .Width = Range(.Name).Width: .Height = Range(.Name).Height
      .AlternativeText = vbNullString
    End If
  End With
End Sub
```
Có khi anh đang nói đến code nào đó đã bị "độ" lại cũng không chừng

Tôi viết rất rõ mà: "Trước hết góp ý về code trong bài #35 và #43"

Ở lần click đầu tiên thì .AlternativeText = "tên ảnh", tức bMark = TRUE

TÁC GIÁ CODE LÀ EM đấy anh à!
Dù là bài 35 hay 36 hay số mấy thì code đó cũng là của em
—————

Anh xem kỹ lại đi: Cả code ở bài 35 và 43 đều không có cái vụ .AlternativeText = "tên ảnh" đâu
Tất cả 2 code trong 2 bài ấy đều đặt điều kiện vầy: bMark = (Len(.AlternativeText) > 0)
Code bài 35:
```
Sub ShpResize()
  Dim pic As Picture
  Dim bMark As Boolean
  Set pic = Sheet1.Pictures(Application.Caller)
  With pic.ShapeRange
    [COLOR=#ff0000]bMark = (Len(.AlternativeText) > 0)
    If bMark = False Then[/COLOR]
      .ScaleWidth 5, msoFalse, msoScaleFromMiddle
      .ScaleHeight 5, msoFalse, msoScaleFromMiddle
   [COLOR=#ff0000]   .AlternativeText = "TRUE"[/COLOR]
      .ZOrder msoBringToFront
    Else
      .Left = Range(.Name).Left: .Top = Range(.Name).Top
      .Width = Range(.Name).Width: .Height = Range(.Name).Height
      [COLOR=#ff0000].AlternativeText = vbNullString[/COLOR]
    End If
  End With
End Sub
```
Code bài 43:
```
Sub ShpResize()
  Dim pic As Shape
  Dim bMark As Boolean
  Set pic = ActiveSheet.Shapes(Application.Caller)
  With pic
   [COLOR=#ff0000] bMark = (Len(.AlternativeText) > 0)
    If bMark = False Then[/COLOR]
      .ScaleWidth 5, msoFalse, msoScaleFromMiddle
      .ScaleHeight 5, msoFalse, msoScaleFromMiddle
      [COLOR=#ff0000].AlternativeText = "TRUE"[/COLOR]
      .ZOrder msoBringToFront
    Else
      .Left = Range(.Name).Left: .Top = Range(.Name).Top
      .Width = Range(.Name).Width: .Height = Range(.Name).Height
     [COLOR=#ff0000] .AlternativeText = ""[/COLOR]
    End If
  End With
End Sub
```
Còn chuyện có tên ảnh trong AlternativeText thì đó cũng là sơ suất của người ta, chẳng ảnh hưởng gì đến code cả. Dù lần đầu click có trục trặc thì những lần sau vẫn êm xuôi
Vậy nên phần code này không cần phải sửa gì cả
(File ở bài 35 bị lỗi là vì 1 chuyện hoàn toàn khác, đã xử lý xong)

Cái này ai cũng kiểm tra được mà. Nhưng thôi, tôi đành mất công vậy

Thao tác: tải về –> giải nén –> kích hoạt Player –> File –> Open –> chọn test.avi –> file –> play

https://www.mediafire.com/download/i01g03uvtivjppb/test.rar

Tôi có nói code không êm xuôi đâu. Tôi chỉ nói "phí" 1 lần click đầu tiên sau khi load ảnh.

Vậy nên phần code này không cần phải sửa gì cả
(File ở bài 35 bị lỗi là vì 1 chuyện hoàn toàn khác, đã xử lý xong)

Tôi có bàn về chuyện lỗi kia đâu???

Mà người góp ý thì cứ góp ý còn việc sửa hay không thì là chuyện của người khác. Chả ai bắt ai đâu mà
————-
Xem video các bạn thấy tôi click lần đầu vào ảnh nhỏ thì theo lôgic sau khi click nó phải to lên do ảnh đang nhỏ. Nhưng nó không to lên

Anh góp ý thì em và mọi người đều cảm ơn (chuyện đương nhiên)
—————————————————-
Ngoài lề một chút:
Em biết là anh đã xem qua topic này vài lần, chắc cũng định bỏ đi rồi nhưng vì thấy thằng em nó sai mà không ai phát hiện nên anh ngứa tay vào đây góp vài lời (em rất cảm ơn về điều này)
Em biết là anh ngại giao tiếp với em nên đã "nói tránh" đi là góp ý cho bài này, bài nọ (không phải bài của em)…
Ẹc… Ẹc… dù là bài nào trong topic này cũng có liên quan đến em thôi
Em khộng ngại mà nói thằng rằng: thời gian gần đây em cũng ngại giao tiếp với anh, vì anh hay nỗi nóng bất thường nên sau này em chẳng khi nào góp ý bất cứ vấn đề gì có liên đến code anh viết (anh thừa hiểu lý do vì sao)
Thôi thì đã lỡ vào đây rồi, có góp ý anh cứ góp ý thẳng (không cần phải "nói tránh" đi đâu). Tính em phân biệt rõ ràng lắm, dù có ghét ai đến mấy nhưng vẫn chịu học hỏi nếu người đó có cái hay… huống chi em với anh dù có "tránh mặt" nhau cũng đâu phải thuộc dạng ghét cay ghét đăng hay thù hằn gì
Anh nghĩ em nói đúng không?
—————————————————-
Ôi… mông lung quá! –=0

Không hiểu Tuấn định gây sự gì nhỉ? Cứ nói hết đi.

Hãy để ý là không chỗ nào tôi nói: bài của Nghĩa, bài của Thanh. Vì tôi thừa biết là không phải. Tôi nói bài #35 và #43 chỉ là để chỉ cho mọi người biết tôi định nói tới bài nào. Vì rất có thể ai đó muốn tải file về để kiểm chứng. Nếu tôi không nói rõ bài nào thì "họ" bằng cách nào biết? Có chỗ nào tôi nói là bài của Nghĩa, của Thanh không? Hay bắt bẻ tôi chỉ vì chuyện tủn mủn? Tôi phải viết thế nào? Là phải viết: "Trước hết góp ý về code trong bài #35 và #43 – tác giả là ndu"??? Không có thêm đoạn "tác giả là ndu" thì là "nói tránh"? Khó hiểu quá.

Còn chuyện mà bạn nói là "anh thừa hiểu lý do vì sao" thì tôi không muốn gợi lại làm gì. Vì cho dù thế nào thì tôi cũng bị gán cái mác "nóng tính", "không biết tiếp thu" … Nhưng tôi rất biết phải trái. Nhiều người nói tôi sai chỗ này, code chỗ nọ bị lỗi. Tôi đã từng xin lỗi và cám ơn nhiều người góp ý. Không có bài nào chỉ ra những sơ xuất trong code mà tôi lờ đi, giả vờ không biết. Mà nhiều người đã và đang giả vờ như thế đấy.

Tôi biết tiếp thu, tôi biết nói lời cám ơn và cả xin lỗi. Không có gì phải hổ thẹn khi nói lời xin lỗi. Nhưng tôi chỉ sẵn sàng tiếp thu, lắng nghe ý kiến khi mà đó là lời góp ý thẳng thắn. Đừng có kiểu muốn góp ý nhưng lại bịa ra chuyện: "nghe nhiều người nói là …". Người ta quan tâm tới code của tôi và rất muốn dùng nhưng có chỗ chưa hiểu? Nếu không quan tâm thì chả ai rỗi hơi đi phàn nàn với người khác. Còn nếu quan tâm, muốn dùng, muốn hỏi thì có lẽ người ta sẽ hỏi trực tiếp tác giả chứ nhỉ? Hay muốn dùng muốn hỏi nhưng tiếc lời, đành tốn chút xèng gọi điện cho người khác để phàn nàn? Tôi không tin có chuyện như thế.

Góp ý? Sẵn sàng, nhưng cứ nói thẳng. Đừng quanh co, bịa tình huống.

Tôi đã quá chán những xung đột không nên có nên cố tình giảm cơ hội đụng độ với mọi người thôi. Nhưng bạn có thể tự bịa ra những lý do mà bạn cho là đúng. Nào là "để bụng", "ghét", "thù". Xin cứ tự nhiên.

Tôi góp ý có cái gì sai không? Nếu sai thì nói ra để tôi rút kinh nghiệm. Còn nếu đúng thì tại sao lại có chuyện "kể" ra những chuyện như trên? Hay là vì: "Anh góp ý đúng rồi nhưng tôi biết tỏng là anh chụp cơ hội để tấn công tôi"? Bởi nếu không thì tại sao lại có những đoạn như trên? Nếu góp ý mà rồi bị chụp mũ như thế thì tôi sẽ không muốn góp ý nữa. Chỉ cần một lời: Tôi không muốn anh góp ý cho những bài của tôi. Chỉ một lời thôi thì có thể yên tâm là tôi sẽ không bao giờ góp ý nữa.

Tôi sẽ không viết thêm gì nữa.
—————–
Tôi đã nói là không viết thêm nữa tức sẽ không có chuyện tranh luận gì ở đây. Vậy đề nghị BQT để nguyên bài này của tôi. Một ý kiến, vài lời giải thích nhưng của người có văn hóa mà. Chuyện nói thẳng vì là toàn là đàn ông mà lại đàn ông có tuổi mà.

Vâng! Có sai chứ anh! Đó là trường hợp anh nói về AlternativeText
Anh cho rằng nên đổi If bMark Then (thay vì If bMark = FALSE Then)
Đó là vì anh cho rằng chuổi trong AlternativeText luôn tồn tại, khi ấy bMark đã = TRUE trước nên phải click lần thứ 2 hình mới được phóng to. Trường hợp này ĐÚNG
Nhưng sao anh chắc rằng chuổi trong AlternativeText luôn tồn tại? Đặt trường hợp mới chèn hình vào, nó rổng thật sự thì nếu sửa code lại như anh góp ý hóa ra cũng lại phải click đến lần thứ 2 ảnh mới được phóng to. Trường hợp này lại SAI
Anh cứ xem video clip sẽ biết: https://www.mediafire.com/download/bibtipaehi6j7ol/test_2.avi
Ở đây, nếu hoàn hảo thì lý ra khi chèn hình ta xử lý xóa chuổi trong AlternativeText luôn mới đúng
(nhưng dù sao chuyện này cũng không quan trọng nên em không nhắc)

Tôi sẽ không viết thêm gì nữa.
—————–
Tôi đã nói là không viết thêm nữa tức sẽ không có chuyện tranh luận gì ở đây. Vậy đề nghị BQT để nguyên bài này của tôi. Một ý kiến, vài lời giải thích nhưng của người có văn hóa mà. Chuyện nói thẳng vì là toàn là đàn ông mà lại đàn ông có tuổi mà.

Hình như anh chưa hiểu ý em thì phải (cũng như bao lần trước)
Em không giỏi ăn nói nhưng được cái là nghĩ sao nói vậy, lý ra anh phải không nên giận thằng em này mới đúng (nó thật lòng)
Dù sao, nếu vì những lời nói của em mà anh phiền lòng thì em thành thật xin lỗi vậy

http://www.giaiphapexcel.com/diendan/threads/th%C3%AAm-1-d%E1%BA%A1ng-picform.3721/post-535205

Reply
hands says:

23/12/2022 at 10:49 am

Các thày cũng cho nhà em nói thẳng là "một nửa" của ta đáng yêu, đáng quý biết bao nhiêu mà nhiều khi vẫn phải "Quay mặt làm ngơ" mà . Với hai thày vừa là "cao thủ" của GPE cả về kiến thức, cả về tuổi đời và cả về đối nhân sử thế ; Máy móc là "kẻ" vô tri mà còn xung đột mà . Theo nhà em thì " Không có giải nhất" là phương án tối ưu , Mong các thày đừng cho rằng nhà em " nói leo " .

Tại anh trai tôi hay nhạy cảm thôi mà. Không có gì đâu!
————————————
Ở trên anh siwtom có 1 gợi ý rất hay về Shapes.AddPicture (cái này quả thật là bây giờ tôi mới biết)
Tôi sẽ cố gắng sưa code theo hướng đi này. Hy vọng có thể giải quyết khó khăn cho bạn
Chờ chút nha…
Đã xong! Code sửa lại khá nhiều
```
Public aFiles, sFolder As String
Sub ShpResize()
  Dim shp As Shape, rngPos As Range
  Dim bMark As Boolean
  On Error Resume Next
  Set shp = ActiveSheet.Shapes(Application.Caller)
  With shp
    Set rngPos = Range(.Name)
    bMark = (Len(.AlternativeText) > 0)
    If bMark = False Then
      .ScaleWidth 3, msoFalse, msoScaleFromMiddle
      .ScaleHeight 3, msoFalse, msoScaleFromMiddle
      .AlternativeText = "TRUE"
      .ZOrder msoBringToFront
    Else
      .Left = rngPos.Left: .Top = rngPos.Top
      .Width = rngPos.Width: .Height = rngPos.Height
      .AlternativeText = ""
    End If
  End With
End Sub
```
```
Sub ShpReset()
  Dim shp As Shape, bMark As Boolean, rngPos As Range
  On Error Resume Next
  For Each shp In ActiveSheet.Shapes
    With shp
      If .Name Like "$*$*" Then
        bMark = (Len(.AlternativeText) > 0)
        Set rngPos = Range(.Name)
        .Left = rngPos.Left: .Top = rngPos.Top
        .Width = rngPos.Width: .Height = rngPos.Height
        If bMark Then .AlternativeText = vbNullString
      End If
    End With
  Next
End Sub
```
```
Sub SelectFolder()
  Dim arr, vFolder, pic
  Dim Target As Range, shp As Shape
  Dim lR As Long
  Dim PicPath As String
  On Error Resume Next
  vFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 1).Self.Path
  If TypeName(vFolder) = "String" Then
    If Right(vFolder, 1) <> "" Then vFolder = vFolder & ""
    arr = FilesFoldersList(vFolder, True, "*.jpg", False)
    If IsArray(arr) Then
      aFiles = arr
      sFolder = CStr(vFolder)
      Range("F1") = sFolder
      For Each pic In arr
        PicPath = sFolder & CStr(pic)
        Set Target = Range("A5").Offset(lR)
        lR = lR + 1
        Set shp = InsertPic(PicPath, Target, "ShpResize")
      Next
      Range("F1").Select
    End If
  End If
End Sub
```
```
Function InsertPic(ByVal PicPath As String, ByVal Target As Range, Optional ByVal Action As String = "") As Shape
  Dim shp As Shape
  On Error Resume Next
  With Target
    .Parent.Shapes(Target.Address).Delete
    Set shp = .Parent.Shapes.AddPicture(PicPath, True, True, .Left, .Top, .Width, .Height)
  End With
  If Not shp Is Nothing Then
    shp.Name = Target.Address
    shp.AlternativeText = ""
    If Val(Application.Version) > 11 Then shp.LockAspectRatio = msoFalse
    shp.OnAction = Action
    Set InsertPic = shp
  End If
End Function
```
—————
Riêng có đoạn bạn Ngoai Thanh hỏi rằng:

Đó là vì ngoài code trong Module còn có code sự kiện Change, SelectionChange (nằm trong Sheet). Bạn copy ra file khác nhưng quên không mang theo mấy code này nên phần Validation list không hoạt động. Chú ý nha!
Phần sự kiện Change trong file mới tôi cũng cải tiến thêm 1 chút: Cho phép copy hoặc xóa cùng lúc nhiều cell (lúc trước chỉ hoạt động có 1 cell)
Vậy nên, giờ đây nếu:
– Bạn xóa 5 cell ở cột B cùng lúc thì 5 cell tương ứng bên cột A sẽ lập tức bị xóa hình
– Bạn copy đâu đó 5 cell rồi paste vào cột B thì lập tức 5 cell bên cột B được chèn hình (nếu tên hình tồn tại)
Kiểm tra lại giúp tôi xem còn chổ nào trục trặc nữa không?

http://www.giaiphapexcel.com/diendan/threads/th%C3%AAm-1-d%E1%BA%A1ng-picform.3721/post-535242

Cám ơn thày ! Code chạy tốt trên Excel 2003 rồi ạ . Song có điều thày giúp nhà em thêm chút nữa là : Tất cả tính năng như File cũ ( Khi điều chỉnh cell ảnh tự động điều chỉnh theo – điều này để điều chỉnh sự cân đối của ảnh )

Khi bạn điều chỉnh kích thước cell xong, chỉ cần click chuột vào 1 cell nào đó là ảnh tự cân chỉnh thôi mà. Tính năng này được thực hiện từ sự kiện SelectionChange:
```
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  On Error Resume Next
  [B][COLOR=#ff0000]ShpReset[/COLOR][/B]
  If Not Intersect(Range("B5:B30"), Target) Is Nothing Then
    If Target.Count = 1 Then
      If IsArray(aFiles) Then
        With Target.Validation
          .Delete
          .Add 3, , , Join(aFiles, ",")
        End With
      End If
    End If
  End If
End Sub
```
Có khi nào bạn đã bỏ quên code này không?

Dù phóng to theo tỷ lệ nào thì khi thu nhỏ ảnh cũng về kích thước ban đầu ( Hiện tại ảnh được thu về theo tỷ lệ , nên có lúc nó thu về kích thước nhỏ hơn cell hiện tại, vả lại kích thước ảnh không phải lúc nào cũng giống nhau nên nhà em phải điều chỉnh chiều rộng và chiều dài khác nhau để cân đối ảnh nên khi thu nhỏ rất cần nó trở lại kích thước ban đầu .
!

Phóng to thì theo tỷ lệ nhưng khi thu nhỏ tôi đâu có viết code để thu nhỏ ngược lại đâu!
Khi thu nhỏ, code chỉnh kích thước hình theo cell mà bạn:
```
Sub ShpResize()
  Dim shp As Shape, rngPos As Range
  Dim bMark As Boolean
  On Error Resume Next
  Set shp = ActiveSheet.Shapes(Application.Caller)
  With shp
    Set rngPos = Range(.Name)
    bMark = (Len(.AlternativeText) > 0)
    If bMark = False Then
      .ScaleWidth 3, msoFalse, msoScaleFromMiddle
      .ScaleHeight 3, msoFalse, msoScaleFromMiddle
      .AlternativeText = "TRUE"
      .ZOrder msoBringToFront
    Else
      [COLOR=#ff0000].Left = rngPos.Left: .Top = rngPos.Top
      .Width = rngPos.Width: .Height = rngPos.Height[/COLOR]
      .AlternativeText = ""
    End If
  End With
End Sub
```
Chổ màu đỏ ấy

Thưa thày, khi đã load ảnh điều chỉnh cell ảnh không điều chỉnh theo đâu ạ . chỉ khi đổi ảnh nó mới điều chỉnh theo kích thước mới thày ạ . Và khi load ảnh thì load cả tên bên cột B ạ .

Bạn đưa file của bạn lên đây xem thử! Tôi test không phát hiện có gì bất thường cả (kích thước ảnh được điều chỉnh ngon lành cho cả 2 trường hợp load ảnh mới và thay đổi ảnh theo validation)

Cám ơn thày Nhà em gưi file để thày kiểm tra giúp ạ .

Trong code này:
```
Function InsertPic(ByVal PicPath As String, ByVal Target As Range, Optional ByVal Action As String = "") As Shape
  Dim shp As Shape
  On Error Resume Next
  With Target
    .Parent.Shapes(Target.Address).Delete
    Set shp = .Parent.Shapes.AddPicture(PicPath, True, True, .Left, .Top, .Width, .Height)
  End With
  If Not shp Is Nothing Then
    shp.Name = Target.Address
    shp.AlternativeText = ""
   [COLOR=#ff0000] If Val(Application.Version) > 11 Then shp.LockAspectRatio = msoFalse[/COLOR]
    shp.OnAction = Action
  End If
End Function
```
Chổ màu đỏ bạn sửa thành
```
[COLOR=#ff0000] shp.LockAspectRatio = msoFalse[/COLOR]
```
Tức bỏ IF ở đàng trước
Do không có Excel 2003 để test và tôi đoán rằng LockAspectRatio chỉ hoạt động từ Excel 2007 trở lên nên đã IF như vậy
Cứ thử bỏ rồi test lại xem sao nhé

Do không có Excel 2003 để test và tôi đoán rằng LockAspectRatio chỉ hoạt động từ Excel 2007 trở lên nên đã IF như vậy
Cứ thử bỏ rồi test lại xem sao nhé

Đúng rồi thày ạ, còn cho hiện tên cùng với ảnh tại list khi load ảnh ngay lần đầu thì sửa code thế nào ạ ?

Quá dễ:
```
Sub SelectFolder()
  Dim arr, vFolder, pic
  Dim Target As Range, shp As Shape
  Dim lR As Long
  Dim PicPath As String
  On Error Resume Next
  vFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 1).Self.Path
  If TypeName(vFolder) = "String" Then
    If Right(vFolder, 1) <> "" Then vFolder = vFolder & ""
    arr = FilesFoldersList(vFolder, True, "*.jpg", False)
    If IsArray(arr) Then
      aFiles = arr
      sFolder = CStr(vFolder)
      Range("F1") = sFolder
      For Each pic In arr
        PicPath = sFolder & CStr(pic)
        Set Target = Range("A5").Offset(lR)
        lR = lR + 1
        Set shp = InsertPic(PicPath, Target, "ShpResize")
        [COLOR=#ff0000]Target.Offset(, 1) = CStr(pic)[/COLOR]
      Next
      Range("F1").Select
    End If
  End If
End Sub
```
Chổ màu đỏ là mới thêm vào

Thày NDU cho nhà em hỏi thêm chút là : nếu lần sau số lượng ảnh nhiều hơn lần trước thì không vấn đề gì . Nhưng nếu ít hơn thì số ảnh thừa vẫn tồn tại nên phải xóa thủ công . Nhà em đã định tự giải quyết bằng cách viết thêm dòng lệnh để xóa luôn 2 cột (A:B) rồi chèn lại 2 cột đó nhưng có vẻ không hay lắm mà dò để sửa code thì sợ code "độ" không đồng bộ . Mong thày chỉ giáo,Tức là xóa ảnh cũ trước khi load ảnh mới .

Cái đó tôi có thấy nhưng chưa tiến hành là vì liên quan đến cái vụ 2003 của bạn đấy!
Bây giờ bạn vui lòng thí nghiệm giùm tôi thế này nhé:
– Mở 1 file Excel trắng
– Chèn 1 vài hình (chèn bằng tay)
– Xong bạn chạy code này thử:
```
Sub Test()
 ActiveSheet.Pictures.Delete
End Sub
```
– Kết quả thế nào, báo tôi biết rồi ta tính tiếp
Lưu ý: thí nghiệm trên phải được thực hiện trên Excel 2003 nhé

Reply
hands says:

23/12/2022 at 10:50 am

Sub chạy tốt thày ạ ! Nhà em hiểu ý thày rồi : cho dòng lệnh trên vào sub SelectFolder Ngay dưới dòng lệnh On Error Resume Next và chạy tốt rồi thày ạ, tức là trước khi lấy ảnh mới thì xóa toàn bộ ảnh cũ . Thấy thày chạy giúp mọi người khắp diễn đàn nhà em thấy ngại thật sự ! Xin Cám ơn thày, người thày tận tụy !

Ai bảo bạn làm thế nhỉ? Không bao giờ Thầy NDU "trảm" Object mà không có tên tuổi! Bạn mà dùng câu lệnh đó thì vô hình chung nó xóa tất cả các hình trên sheet thì khổ đấy! Trừ khi bạn muốn là thế!

Đúng rồi đó thầy ! Vì sau đó ta nạp ảnh mới toàn bộ mà , còn nếu muồn thay một vài ảnh thì thay bằng list chứ không chạy sub nữa . Kể thày nhắc cũng nguy hiểm , nhỡ ai đó "bấm chơi" một cài thì tèo ( nếu vậy thì bỏ nút bấm và chạy bằng lệnh tắt, nếu ai không biết lệnh thì không chạy được ) , Nghe có vẻ không ổn lắm . Nhưng thực nhà em thấy phiền các thày nhiều nên cố tự lực chút ! cám ơn thày chỉ dẫn .

Nếu bạn muốn xóa tất cả thì tôi cũng có một cái thủ tục cho bạn, nó xóa tất Picture, kể cả những Shape!

ActiveSheet.DrawingObjects.Delete

Tuy nhiên, tôi không khuyến khích bạn dùng thủ tục này, bởi một lúc nào đó ta giữ vài hình ảnh lại, LOGO cty chẳng hạn, đã là một chương trình gì đó, bạn không muốn để một vài hình ảnh về bạn sao nhỉ?

Thực ra Thày nhắc mới nhớ, nói chung có vẻ không an toàn . Yêu cầu là xóa toàn bộ ảnh đã nạp vào cột B thày ạ , vậy dòng lệnh viết thế nào ạ ?

Chỉ có thể là dùng vòng lặp thôi! Đặt tên hình cũng rất quan trọng, nếu đặt tên theo địa chỉ ô như Thầy NDU làm thì rất dễ quản lý, muốn xóa cũng rất thuận tiện!
Không biết trên Excel 2003 bạn có thể xóa hình bằng cách này không nhỉ:
```
Sub XoaHinh()
    ActiveSheet.Shapes.Range(Array([COLOR=#0000ff]"Picture 1", "Picture 2", "Picture 3"[/COLOR])).Delete
End Sub
```
Bạn thử insert các picture và đặt tên lần lượt như các tên có màu xanh rồi cho chạy thủ tục đó xem nó có dùng được không, hiện tại tôi đang dùng Excel 2010 nên không test được!

http://www.giaiphapexcel.com/diendan/threads/th%C3%AAm-1-d%E1%BA%A1ng-picform.3721/post-535420

Bây giờ nhà em chỉ cần xóa hết ảnh từ B5 trở đi để nạp ảnh mới . Vì dòng lệnh trên xóa hết ảnh trên sheet nên không an toàn . Hay nhất là sửa được câu lệnh xóa ảnh cũ nạp ảnh mới Thành xóa toàn bộ ảnh cũ trước khi nạp ảnh mới thày ạ, nhưng nhà em không biết sửa thế nào vì code liên quan đến tất cả các sub nên nhà em không dám mạo hỉểm .
Chắc chắn là được, thày ạ . Nhưng tên ảnh không đổi được, từ hôm qua đến giờ thày NDU đã giúp và sử dụng tốt rồi ạ ( tức là nạp ảnh và cà tên theo thư mục ảnh ). Giờ chỉ cần xóa ảnh cũ vì nếu lần nạp sau ít ảnh hơn lần trước đó thì còn một số ảnh trước đó vẫn tồn tại ngoài yêu cầu mà thày . cần xóa số ảnh thừa này ạ.

Haha, bạn có biết khi tôi vọc code, tôi đã lưu lại nhiều file không? Hoặc giả tôi vọc tùm lum nhưng khi thoát tôi không lưu lại hoặc save as thành file mới không? Bạn cứ vọc thoải mái sợ quái gì code chứ!

"Vọc" code thì nhà em "vọc" nhiều rồi, nhưng với code down trên diễn đàn về vì thấy hay hoặc gần đúng với yêu cầu của mình thì sửa theo ý mình, nếu không được thì bỏ . Nhưng đây là công sức của các thày bỏ ra để giúp cụ thể theo yêu cầu file của mình vả lại trình độ các thày cao hơn nhà em rất nhiều nên sửa kiểu gì cũng "lợn lành thành lợn què thôi ", bởi xem code phần lớn còn chưa hiểu , sao dám sửa ạ ! Nhưng thày khuyến khích " Sợ quái gì nó " nên nhà em coppy sang một tập rồi "Vọc đại đi ", cuối cùng thì có vẻ nó "nể" mình nên chạy . Lúc đầu do cứ tìm cách chọn ảnh để xóa nên thất bại (nó yêu cầu phải chọn từng ảnh theo từng cell theo địa chỉ tuyệt đối hoặc đích danh tên ảnh , nó mới xóa ). Cuối cùng nhà em thêm 2 câu lệnh sau vào ngay đầu code để nó xóa ảnh cũ trước khi load ảnh mới :
Range(, .End(xlDown).Resize(, 1)).Select
Selection.ClearContents
Té ra không phải ảnh load vào comment mà là trên cell và do tên tại cột B sinh ra , (cột A chỉ là cái khung chứa ảnh) nên nó nghe, trước đó cứ chọn cột A để xóa nên không đựợc . Cám ơn các thày đã giúp đỡ và chỉ dẫn .

Reply
hands says:

23/12/2022 at 10:53 am

Kể thày nhắc cũng nguy hiểm , nhỡ ai đó "bấm chơi" một cài thì tèo ( nếu vậy thì bỏ nút bấm và chạy bằng lệnh tắt, nếu ai không biết lệnh thì không chạy được ) , Nghe có vẻ không ổn lắm . Nhưng thực nhà em thấy phiền các thày nhiều nên cố tự lực chút ! cám ơn thày chỉ dẫn .

Chẳng sao cả!
Nếu bạn chắc rằng trên bảng tính không có bất cứ HÌNH nào "ngoài luồng" thì chơi được. Ở đây tôi nhắc đến từ HÌNH có nghĩa là Picture, các object khác (như hình vẽ, button…) không được tính
Vậy code thế này:
```
Sub SelectFolder()
  Dim arr, vFolder, pic
  Dim Target As Range, shp As Shape
  Dim lR As Long
  Dim PicPath As String
  On Error Resume Next
  vFolder = CreateObject("Shell.Application").BrowseForFolder(0, "", 1).Self.Path
  If TypeName(vFolder) = "String" Then
    If Right(vFolder, 1) <> "" Then vFolder = vFolder & ""
    arr = FilesFoldersList(vFolder, True, "*.jpg", False)
    If IsArray(arr) Then
      [COLOR=#ff0000]ActiveSheet.Pictures.Delete[/COLOR]
      aFiles = arr
      sFolder = CStr(vFolder)
      Range("F1") = sFolder
      For Each pic In arr
        PicPath = sFolder & CStr(pic)
        Set Target = Range("A5").Offset(lR)
        lR = lR + 1
        Set shp = InsertPic(PicPath, Target, "ShpResize")
        Target.Offset(, 1).Value = CStr(pic)
      Next
      Range("F1").Select
    End If
  End If
End Sub
```
Sẽ không lo bấm bậy
————–
Trường hợp khác: trên sheet, ngoài hình chèn bằng code còn có những hình khác được chèn bằng tay. Để xóa những hình trước đó đã nạp (tại cột A) thì thay đoạn màu đỏ ở trên bằng code:
```
Range("B5:B1000").ClearContents
```
Kể thày nhắc cũng nguy hiểm , nhỡ ai đó "bấm chơi" một cài thì tèo ( nếu vậy thì bỏ nút bấm và chạy bằng lệnh tắt, nếu ai không biết lệnh thì không chạy được ) , Nghe có vẻ không ổn lắm . Nhưng thực nhà em thấy phiền các thày nhiều nên cố tự lực chút ! cám ơn thày chỉ dẫn .

Thay vì Select, rồi lại Selection.ClearContents. Bạn có thể gộp lại thành:
Range(, .End(xlDown).Resize(, 1)).ClearContents
Tuy nhiên, dùng End(xlDown) có khi bị "sa bẫy" trong trường hợp cột B có cell rổng ở giữa nha

Úi dà ! Nhà em vừa gửi bài xong quay lại thấy bài của thày. May quá, đúng ý của thày luôn, thày cho nhà em "cắp tráp " theo hầu , được không ạ ? Tiếc thật, nếu ở gần , dứt khoát nhà em đến thăm hầu chuyện thầy một hôm .Xin cám ơn thày !Vâng , vì nó load ảnh tự động lần lượt vào các cell , không phải chèn bằng tay nên chắc không "rỗng " ạ .Trừ phi ta del nó . Cám ơn thày !

Thì tôi đang nói đến cái vụ "trừ phi" này nè
Tức là trước khi load ảnh, trên bảng tính đã có ảnh và dữ liệu. Mà dữ liệu cột B lại không liên tục, End(xlDown) sẽ bị "ngắt ngang" giữa chừng —> Ý là vậy đấy
(Tôi làm việc gì, nhất là những việc QUAN TRỌNG rất ghét bị "ngắt ngang" lắm… Ẹc… Ẹc… –=0)

Dạ, vậy thì dùng End(xlUp) được không ạ ? Thày giúp em câu lệnh chọn từ B5 đén ô cuối từ dưới lên với ạ ? lắm lúc do không quen nhà em cứ loay hoay mãi mà viết không đúng , nó không nghe, nó "cãi" ghê lắm ạ .Nếu nó là con, nhà em cho nó "mấy que vào đít " rồi . Nói thày đừng cười , nhà em VBA cò gà mờ lắm ạ !
Dạ, nó nghe rồi thày ạ !
Range(, .End(xlUp).Resize(, 1)).ClearContents

Chổ màu đỏ là thừa nha!
Ngoài ra bạn hãy thí nghiệm cho trường hợp đặc biệt này: Load ảnh khi cột B không có bất cứ dữ liệu nào còn cột A thì có dữ liệu từ A1 đến A4
Bạn sẽ thấy code trên xoá nhầm dữ liệu đấy
Bởi vậy khi viết code tôi rất ghét cái vụ End(xlUp) hoặc End(xlDown) —> Bạn dự trù dữ liệu đến đâu thì cứ xoá đến nấy đi. Đơn giản là Range("A5:B1000").ClearContents mà chơi thôi

Xin thưa với Thầy là Insert Pictures thì được, tức câu lệnh này:

Target.Parent.Pictures.Insert(PicPath)

Nhưng xoá Pictures thì câu này lại không được:

Target.Parent.Pictures(Target.Address).Delete

Còn tại sao thì hỏi Anh Bill thôi! Hic

—————-

Cũng như câu này:

Sheet1.Pictures(Application.Caller)

Đối với Ex2003 nó không hiểu, nhưng câu dưới lại hiểu:

Sheet1.Shapes(Application.Caller)

Bài này đúng ra đã giải quyết xong nhưng thật lòng tôi vẫn ấm ức. Đánh chết tôi cũng không tin rằng Pictures object không dùng được trên Excel 2003
Mày mò tìm phần mềm Portable 2003 để thử, cuối cùng cũng phát hiện ra nguyên nhân: Trên Excel 2003, code VBA sẽ không làm việc nếu trong tên của Picture có ký tự "$"
Vậy là xong! Chỉ cần đặt lại tên file ảnh không có ký tự chết tiệt này (thay Address bằng Address(0,0) ) là mọi chuyện được giải quyết
Mời thử file

Đúng là nhờ cái việc ấm ức này mà Thầy đã tìm ra nguyên nhân chính là do ký tự đặc biệt đã ảnh hưởng đến câu lệnh.

Không những ký tự $ không thôi mà còn nhiều ký tự như @, &, #, v.v… khi ta đặt tên hình có các ký tự đó sẽ bị lỗi khi dùng câu lệnh này:

Sheet1.Pictures("Picture***").Delete

(với *** là ký tự đặc biệt)

Nhưng với câu lệnh này:

Sheet1.Shapes("Picture***").Delete

Thì không hề bị lỗi đó.

Cho nên, khi gặp rủi ro thì ta cố gắng chọn những rủi ro ít gây thiệt hại nhất để thực hiện, vậy thì theo em, em sẽ chọn phương án SHAPES thay cho phương án PICTURES, đó là một câu lệnh tối ưu, xét về thời gian thì cả 2 câu lệnh tương đương nhau, đôi khi dùng SHAPES để xóa còn nhanh hơn tí xíu (cho 2000 hình)

Sở dĩ tôi không chọn SHAPES mà chọn PICTURES vì quan điểm cua tôi là: Luôn gọi Object đúng với KIỂU của nó
Ví dụ:
– Với hình vuông, tôi sẽ dùng Rectangles
– Với đường thằng, tôi sẽ dùng Lines
vân vân… tương tự vậy với Pictures. Mục đích là gọi cái nào ra cái đó, không chơi kiểu gọi chung chung (trừ trường hợp bất khả kháng)
Về tốc độ tôi nghĩ chưa chắc là giống nhau đâu. Bởi SHAPES là nói chung chung cho mọi object (kể cả ActiveX control). Vậy đương nhiên bộ nhớ phân phối cho nó phải lớn hơn so với việc ta phân biệt rõ ràng cái nào thuộc về loại object nào

Reply