Thêm 1 dạng PicForm (2 người xem)

anhtuan1066 · 1/9/07

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
ANH TUẤN

anhtuan1066 · 12/12/08

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

PHP:

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)

anhtuan1066 · 14/12/08

Lại tiếp tục cải tiến:

PHP:

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([B5:B8], 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)

chiphoi3 · 29/9/09

Hàm của anh tuấn có thể insert thủ công được, tuy nhiên khi dùng chức năng fill down thì tất cả hình lại giống nhau, mặc dù đường dẫn của nó lại khác nhau

HOANG 1978 · 22/4/11

Tôi rât cảm ơn bài viết này đã giúp tôi giải quyết được vấn đề khó mà tôi đang vướng mắcNhưng trên file của tôi có nhiều hình lắm và tôi phải lấy hình từ một sheet khác.Một lần nữa cho tôi cám ơn bài viết này, cảm ơn bạn đã giúp tôi

tat thanh · 15/7/11

Anh Tuấn Ơ i ! Cho đứa Em Ngốc Nghếc này hỏi Anh thê m một chút nữa vêề đ oạn code chạy hình trong excel của Anh nhé ;(Set PicRng = Range("G1").CurrentRegion '<--- Dat ten cho vung tra cuu hinh) Anh dặt tê n cho vùng tra cứu hình là G1 vậy Anh vao dau de dat vay.them nua ( Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC) day la duong dan den file hinh vay Em muon khai bao lai duong dan khac thi vao dau de khai vay Anh. Nho Anh chi dum Em voi nha . cam on Anh that nhieu

Hoàng Trọng Nghĩa · 15/7/11

tat thanh đã viết:
Anh Tuấn Ơ i ! Cho đứa Em Ngốc Nghếc này hỏi Anh thê m một chút nữa vêề đ oạn code chạy hình trong excel của Anh nhé ;(Set PicRng = Range("G1").CurrentRegion '<--- Dat ten cho vung tra cuu hinh) Anh dặt tê n cho vùng tra cứu hình là G1 vậy Anh vao dau de dat vay.

Dĩ nhiên dựa vào hình ảnh để đặt tên, máy không có tên này đâu nhé! Mục đích đặt tên này là để làm cái LookUp_Value, và dò tìm giá trị ở cột thứ 2 để chọn đường dẫn tới hình ảnh mà thôi.

tat thanh đã viết:
Them nua ( Pos = WorksheetFunction.VLookup(Target, PicRng, 2, 0) '<--- Xac dinh vi trí chua file hinh tren PC) day la duong dan den file hinh vay Em muon khai bao lai duong dan khac thi vao dau de khai vay Anh. Nho Anh chi dum Em voi nha . cam on Anh that nhieu

Muốn khai báo lại đường dẫn, bạn khai báo trong cột H, từ H1 trở đi.

Lưu ý: Khi hỏi bài hay post bài, bạn nên gõ dấu tiếng Việt cho rõ ràng bạn nhé!

techmodule · 25/12/11

Xin nhờ các bác, các anh các chị giúp đỡ, gấp gấp

Xin chào quý anh chị trên diễn đàn
Hiện tại em đang làm file báo giá tự động bằng excel (file đính kèm)
Em đã có tab data và tab list báo giá. Nhưng tab in báo giá thì thông số kĩ thuật và hình ảnh thì không hiện ra được?
Em cũng đọc qua Picform nhưng k hiểu lắm.
Vậy các anh chị ở đây có thể làm giúp em được không ạ.
XIn cảm ơn trước
http://dl.dropbox.com/u/2000670/Bang bao gia techmodule viet.xlsx

techmodule · 26/12/11

Hông có ai giúp em à

ali3340tc · 5/4/13

anhtuan1066 đã viết:

Lại tiếp tục cải tiến:

PHP:

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([B5:B8], 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)

Các bác pro cho hỏi: trong file của bác Tuấn thì cần phải có địa chỉ của ảnh thì mới Vlookup được. Nếu file ảnh và file excel cùng 1 folder và chuyển folder này từ địa chỉ này qua địa chỉ khác thì phải thay đổi địa chỉ file ở vùng vlookup. Làm thế nào để thay đổi địa chỉ mà không phải update lại địa chỉ?

ndu96081631 · 6/4/13

ali3340tc đã viết:
Các bác pro cho hỏi: trong file của bác Tuấn thì cần phải có địa chỉ của ảnh thì mới Vlookup được. Nếu file ảnh và file excel cùng 1 folder và chuyển folder này từ địa chỉ này qua địa chỉ khác thì phải thay đổi địa chỉ file ở vùng vlookup. Làm thế nào để thay đổi địa chỉ mà không phải update lại địa chỉ?

Thế thì tham khảo thử bài này xem:
http://www.giaiphapexcel.com/forum/showthread.php?51408-Chèn-hình-vào-cell-bằng-hàm-tự-tạo

ali3340tc · 6/4/13

ndu96081631 đã viết:
Thế thì tham khảo thử bài này xem:
http://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

Cảm ơn thầy. Em đã làm được thành công.

M@trixs · 27/9/13

anhtuan1066 đã viết:
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

PHP:

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àm sao để thêm được hình khác theo bài này nữa vậy bạn @

anhtuan1066

anhtuan1066 · 27/9/13

M@trixs đã viết:
Làm sao để thêm được hình khác theo bài này nữa vậy bạn anhtuan1066

Bạn cho toàn bộ code này vào sheet nhé:

Mã:

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)

M@trixs · 27/9/13

anhtuan1066 đã viết:
Bạn cho toàn bộ code này vào sheet nhé

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

Ngoai Thanh · 27/9/13

anhtuan1066 đã viết:

Lại tiếp tục cải tiến:

PHP:

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([B5:B8], 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)

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 .

ndu96081631 · 28/9/13

Ngoai Thanh đã viết:
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

M@trixs đã viết:
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

Ngoai Thanh · 28/9/13

ndu96081631 đã viết:
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

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ũ . Đ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 .

ndu96081631 · 28/9/13

Ngoai Thanh đã viết:
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

Ngoai Thanh đã viết:
Đ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:
http://www.giaiphapexcel.com/forum/showthread.php?51408-Chèn-hình-vào-cell-bằng-hàm-tự-tạo

Ngoai Thanh · 28/9/13

ndu96081631 đã viết:
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
***
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ữ .

anhtuan1066 · 28/9/13

Ngoai Thanh đã viết:
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

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!)

Ngoai Thanh · 28/9/13

anhtuan1066 đã viết:
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 .

anhtuan1066 · 28/9/13

Ngoai Thanh đã viết:
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à em đã text thử , nói chung code lấy ảnh và compic ảnh chay tốt , riêng code ShpResize và ShpReset 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 ShpReset mới chạy . Nhưng hình như nó chạy 2 code tức thì nên ảnh chỉ chớp 1 cái rồi tắt, 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

Ngoai Thanh · 28/9/13

anhtuan1066 đã viết:
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 .

Ngoai Thanh · 30/9/13

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[/QUOTE]

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 ô .
- 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 !

anhtuan1066 · 30/9/13

Ngoai Thanh đã viết:
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:

Mã:

Sub SelectFolder()
  Dim arr, vFolder, [COLOR=#ff0000]pic, Target As Range[/COLOR]
[COLOR=#ff0000]  Dim lR As Long[/COLOR]
[COLOR=#ff0000]  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[/COLOR]
[COLOR=#ff0000]        PicPath = sFolder & CStr(pic)[/COLOR]
[COLOR=#ff0000]        InsertPic PicPath, Target, "ShpResize"[/COLOR]
[COLOR=#ff0000]        Set Target = Range("A5").Offset(lR)[/COLOR]
[COLOR=#ff0000]        lR = lR + 1[/COLOR]
[COLOR=#ff0000]      Next[/COLOR]
      Range("F1").Select
    End If
  End If
End Sub

Đồng thời thêm 1 Sub nữa:

Mã:

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

Ngoai Thanh đã viết:
- 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

Ngoai Thanh · 30/9/13

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[/QUOTE]
***
Sub ShpResize()
Dim pic As Picture
Dim bMark As Boolean
Set pic = Sheet1.Pictures(Application.Caller)
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 ạ !

Hoàng Trọng Nghĩa · 30/9/13

Ngoai Thanh đã viết:
Set pic = Sheet1.Pictures(Application.Caller)

Nó báo lỗi tại dòng màu xanh đậm trên ạ !

Tôi đang nghĩ, cái Picture đó bạn có để trong SHEET1 (Sheet Code Name) hay không!

Ngoai Thanh · 30/9/13

Ảnh nằm trong sheet1 mà thày, tức là nếu chạy trên Excel 2010 thì chạy tốt, nhưng ghi với đuôi .xls thì nó không chạy .

Hoàng Trọng Nghĩa · 30/9/13

Ngoai Thanh đã viết:
Ảnh nằm trong sheet1 mà thày, tức là nếu chạy trên Excel 2010 thì chạy tốt, nhưng ghi với đuôi .xls thì nó không chạy .

Bạn thử thay Sheet1 bằng ActiveSheet xem sao. Nhưng thử gửi cái file đó lên xem, biết đâu nó cũng không phải lỗi tại đó.

anhtuan1066 · 30/9/13

Ngoai Thanh đã viết:

Mã:

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 ạ !

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)

Ngoai Thanh · 30/9/13

anhtuan1066 đã viết:
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 ạ!

Ngoai Thanh · 30/9/13

Hoàng Trọng Nghĩa đã viết:
Bạn thử thay Sheet1 bằng ActiveSheet xem sao. Nhưng thử gửi cái file đó lên xem, biết đâu nó cũng không phải lỗi tại đó.

Thay Activesheet vào Sheet1 vẫn vậy ạ !

Hoàng Trọng Nghĩa · 30/9/13

Ngoai Thanh đã viết:
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 thay chữ ActiveSheet.Pictures bằng ActiveSheet.Shapes

Ngoai Thanh · 30/9/13

Hoàng Trọng Nghĩa đã viết:
Bạn thay chữ ActiveSheet.Pictures bằng ActiveSheet.Shapes

Không được thày ạ !Nhà em gửi file để thày các thày xem giúp .

ndu96081631 · 30/9/13

Ngoai Thanh đã viết:
Không được thày ạ !Nhà em gửi file để thày các thày xem giúp .

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)

Hoàng Trọng Nghĩa · 30/9/13

ndu96081631 đã viết:
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)

Vừa định nói như thế thì Thầy đã post bài lên rồi! Xóa 5 hình chồng lên là được!

Hoàng Trọng Nghĩa · 30/9/13

Nhưng với Excel 2003 cũng bị lỗi! Bạn sửa lại code như sau:

Mã:

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!

ndu96081631 · 30/9/13

Hoàng Trọng Nghĩa đã viết:
Vừa định nói như thế thì Thầy đã post bài lên rồi! Xóa 5 hình chồng lên là được!

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

Ngoai Thanh · 30/9/13

ndu96081631 đã viết:
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à 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á .

Ngoai Thanh · 30/9/13

Hoàng Trọng Nghĩa đã viết:

Nhưng với Excel 2003 cũng bị lỗi! Bạn sửa lại code như sau:

Mã:

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!

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 .

Ngoai Thanh · 30/9/13

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 .

Hoàng Trọng Nghĩa · 30/9/13

Ngoai Thanh đã viết:
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 .

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á!

Ngoai Thanh · 30/9/13

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 .

Hoàng Trọng Nghĩa · 30/9/13

Ngoai Thanh đã viết:
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:

Mã:

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

Thành câu lệnh này thử xem sao!

Mã:

ActiveSheet.Shapes(Target.Address).Delete

ndu96081631 · 30/9/13

Hoàng Trọng Nghĩa đã viết:
Tại Sub InsertPic, bạn thay câu lệnh này:

Mã:

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

Thành câu lệnh này thử xem sao!

Mã:

ActiveSheet.Shapes(Target.Address).Delete

Target.Parent với ActiveSheet là mấy thứ trời?

ndu96081631 · 30/9/13

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

Hoàng Trọng Nghĩa · 30/9/13

ndu96081631 đã viết:
Target.Parent với ActiveSheet là mấy thứ trời?

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!

ndu96081631 · 30/9/13

Hoàng Trọng Nghĩa đã viết:
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)

Hoàng Trọng Nghĩa · 30/9/13

ndu96081631 đã viết:
Nói thật nha: Cái này TÔI KHÔNG TIN!

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!

Ngoai Thanh · 30/9/13

ndu96081631 đã viết:
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

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 ạ ?

ndu96081631 · 30/9/13

Hoàng Trọng Nghĩa đã viết:
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ì?

Ngoai Thanh · 30/9/13

Hoàng Trọng Nghĩa đã viết:
Tại Sub InsertPic, bạn thay câu lệnh này:

Mã:

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

Thành câu lệnh này thử xem sao!

Mã:

ActiveSheet.Shapes(Target.Address).Delete

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á .

Hoàng Trọng Nghĩa · 30/9/13

ndu96081631 đã viết:
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ì?

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)

ndu96081631 · 30/9/13

Ngoai Thanh đã viết:
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)

ndu96081631 · 1/10/13

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)

Hoàng Trọng Nghĩa · 1/10/13

ndu96081631 đã viết:
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à!

Ngoai Thanh · 1/10/13

ndu96081631 đã viết:
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)

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 ạ !

ndu96081631 · 1/10/13

Hoàng Trọng Nghĩa đã viết:
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à!

Ngoai Thanh đã viết:
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

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

Ngoai Thanh đã viết:
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!

Ngoai Thanh · 1/10/13

ndu96081631 đã viết:
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ế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 !

ndu96081631 · 1/10/13

Ngoai Thanh đã viết:
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)

Ngoai Thanh · 1/10/13

ndu96081631 đã viết:
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 .

siwtom · 1/10/13

Ngoai Thanh đã viết:
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

Mã:

        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

Mã:

        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

Mã:

    If bMark = False Then
         .ScaleWidth 5, msoFalse, msoScaleFromMiddle
...
         .AlternativeText = "TRUE"
    Else
         .AlternativeText = ""
    End If

thành

Mã:

    [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̀?

ndu96081631 · 1/10/13

siwtom đã viết:
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

Mã:

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

siwtom đã viết:
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

Mã:

If bMark = False Then .ScaleWidth 5, msoFalse, msoScaleFromMiddle ... .AlternativeText = "TRUE" Else .AlternativeText = "" End If

thành

Mã:

[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:

Mã:

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

siwtom · 1/10/13

ndu96081631 đã viết:
Chổ này thì đúng. Em sơ sót
Nhưng chổ này

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:

Mã:

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

ndu96081631 · 1/10/13

siwtom đã viết:
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
---------------

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

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:

Mã:

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:

Mã:

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)

siwtom · 1/10/13

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

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

ndu96081631 đã viết:
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:

Mã:

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:

Mã:

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

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

Ngoai Thanh · 1/10/13

Cám ơn thày NDU và thày Siwtom, nhà em mới được hơn 1 tuổi GPE nên chủ yếu là học và chủ yếu là hỏi chứ chưa dám trả lời và càng không dám bàn về thuật toán, về Vba . Nếu text code chạy đúng yêu cầu cẩn hỏi thì cám ơn và sử dụng, nếu chưa được thì lại vào nhờ các thày sửa giúp đến lúc đạt yêu cầu thì thôi . Lần này thằng Excel 2003 nó làm loạn lên, ngại quá . Xin cám ơn các thày .

ndu96081631 · 1/10/13

siwtom đã viết:
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̀

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

siwtom · 1/10/13

ndu96081631 đã viết:
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á!

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̀.

ndu96081631 · 2/10/13

siwtom đã viết:
K
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 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?

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: http://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)

siwtom đã viết:
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

Ngoai Thanh · 2/10/13

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 " .

ndu96081631 · 2/10/13

Ngoai Thanh đã viết:
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...

ndu96081631 · 2/10/13

Đã xong! Code sửa lại khá nhiều

Mã:

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

Mã:

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

Mã:

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

Mã:

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:

Ngoai Thanh đã viết:
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

Đó 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?

Ngoai Thanh · 2/10/13

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?[/QUOTE]
-----
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 )
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 .
kể cả hiện tên của ảnh tại cột B ngay từ đầu, chỉ khi nào cần đổi ảnh thì mới dùng list để đổi . Nói thế này cho dễ hiểu thày ạ : Các yêu cầu như file cũ chạy trên Excel 2010 là chuẩn rồi , Bây giờ sử lý file này chạy trên Excel 2003 cũng như vậy để cho nó đồng bộ thày ạ ? Xin cám ơn và chào thày !

ndu96081631 · 2/10/13

Ngoai Thanh đã viết:
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:

Mã:

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?

Ngoai Thanh đã viết:
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:

Mã:

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

Ngoai Thanh · 2/10/13

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 ạ .

ndu96081631 · 2/10/13

Ngoai Thanh đã viết:
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 ạ .

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)

Ngoai Thanh · 2/10/13

ndu96081631 đã viết:
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 ạ .

ndu96081631 · 2/10/13

Ngoai Thanh đã viết:
Cám ơn thày Nhà em gưi file để thày kiểm tra giúp ạ .

Trong code này:

Mã:

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

Mã:

[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é

Ngoai Thanh · 2/10/13

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é[/QUOTE]

Đú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 ạ ?

ndu96081631 · 2/10/13

Ngoai Thanh đã viết:
Đú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ễ:

Mã:

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

Ngoai Thanh · 2/10/13

Cám ơn thày ! hoàn chỉnh rồi thày ạ . Nhưng Danh hiệu ăn GPe, ở GPe của thày đúng cả nghĩa bóng và nghĩa đen . Vì diễn đàn lúc nào cũng thấy thầy có mặt . Vậy thầy bật mí cho bọn em biết buổi trưa thày vẫn ngồi trên máy thì "cô giáo " cho ăn gì ạ ?

Ngoai Thanh · 2/10/13

Có lẽ nhà em phiền nhiều quá, Nhà em đã viết thêm dòng lệnh xóa cả cột B, rồi chèn lại . Kể không pro lắm nhưng nó chạy tàm tạm rồi ạ. Xin cám ơn thày !

ndu96081631 · 2/10/13

Ngoai Thanh đã viết:
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ử:

Mã:

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é

Ngoai Thanh · 2/10/13

ndu96081631 đã viết:
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ử:

Mã:

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é

Cám ơn thày, nhà em sợ thày bận nên mày mò . Vâng nhà em sẽ thử và thông báo ạ !

Ngoai Thanh · 2/10/13

ndu96081631 đã viết:
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ử:

Mã:

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é

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 !

Hoàng Trọng Nghĩa · 2/10/13

Ngoai Thanh đã viết:
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 ạ . Cám ơn thà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ế!

Ngoai Thanh · 2/10/13

Hoàng Trọng Nghĩa đã viết:
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 .

Hoàng Trọng Nghĩa · 2/10/13

Ngoai Thanh đã viết:
Đúng rồi đó thầy ! Vì sau đó ta nạp ảnh mới toàn bộ mà , 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ỉ?

Ngoai Thanh · 2/10/13

Hoàng Trọng Nghĩa đã viết:
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 ạ ?

Hoàng Trọng Nghĩa · 2/10/13

Ngoai Thanh đã viết:
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!

Hoàng Trọng Nghĩa · 2/10/13

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ỉ:

Mã:

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!

Ngoai Thanh · 2/10/13

Hoàng Trọng Nghĩa đã viết:
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!

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 .

Ngoai Thanh · 2/10/13

Hoàng Trọng Nghĩa đã viết:
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ỉ:

Mã:

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!

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 ạ.

Hoàng Trọng Nghĩa · 2/10/13

Ngoai Thanh đã viết:
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 .

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ứ!

Ngoai Thanh · 3/10/13

Hoàng Trọng Nghĩa đã viết:
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([A5], [B5].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 .

ndu96081631 · 3/10/13

Ngoai Thanh đã viết:
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:

Mã:

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:

Mã:

Range("B5:B1000").ClearContents

ndu96081631 · 3/10/13

Ngoai Thanh đã viết:
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([A5], [B5].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 .

Thay vì Select, rồi lại Selection.ClearContents. Bạn có thể gộp lại thành:
Range([B5], [B5].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

Ngoai Thanh · 3/10/13

ndu96081631 đã viết:
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:

Mã:

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:

Mã:

Range("B5:B1000").ClearContents

Ú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 !

Thêm 1 dạng PicForm (2 người xem)

Người dùng đang xem chủ đề này

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

File đính kèm

Thành viên mới

Thành viên mới

Thành viên mới

Chuyên gia GPE

Thành viên mới

Thành viên mới

Thành viên chính thức

Huyền thoại GPE

Thành viên chính thức

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

Thành viên gạo cội

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

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

File đính kèm

Thành viên gạo cội

File đính kèm

Cánh Diều xanh

Thành viên gạo cội

Cánh Diều xanh

Cánh Diều xanh

Thành viên gạo cội

Cánh Diều xanh

Chuyên gia GPE

Cánh Diều xanh

Chuyên gia GPE

Thành viên gạo cội

Cánh Diều xanh

Cánh Diều xanh

Chuyên gia GPE

Cánh Diều xanh

File đính kèm

Huyền thoại GPE

Chuyên gia GPE

Chuyên gia GPE

Huyền thoại GPE

Cánh Diều xanh

Cánh Diều xanh

Cánh Diều xanh

Chuyên gia GPE

File đính kèm

Cánh Diều xanh

Chuyên gia GPE

Huyền thoại GPE

Huyền thoại GPE

Chuyên gia GPE

Huyền thoại GPE

Chuyên gia GPE

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

Chuyên gia GPE

Huyền thoại GPE

Huyền thoại GPE

Chuyên gia GPE

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

Huyền thoại GPE

Cánh Diều xanh

Thành viên gắn bó

Huyền thoại GPE

Thành viên gắn bó

Huyền thoại GPE

Thành viên gắn bó

Cánh Diều xanh

Huyền thoại GPE