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

[anhtuan1066]

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]

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]

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]

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]

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]

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]

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

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

 

[Ngoai Thanh]

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]

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]

Ả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]

Ả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]

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]

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]

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]

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]

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]

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]

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]

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!

 

[ndu96081631]

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]

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