Chuyển hình trên bảng tính vào Comment (1 người xem)

[ndu96081631]

Đồng nghiệp của tôi có một bài toán nhờ giúp như thế này:
- Trên bảng tính hiện đang có dữ liệu và 1 số hình nằm tại các cell nào đó (như hình)






























- Giờ người ta muốn chuyển toàn bộ những hình này vào Comment tương ứng với cell chứa hình đó
Ví dụ: Hình đang nằm tại cell B3 thì chèn 1 Comment tại B3, xong lấy hình ấy fill đầy comment vừa chèn
------------------------------------------
Nếu làm bằng tay, đầu tiên tôi sẽ Save từng hình vào máy tính, xong lại load ngược vào Comment... Vài chục hình cũng ráng làm được chứ vài trăm đến vài ngàn hình thì.. đuối
------------------------------------------
Tôi cũng đã nghĩ ra 1 vài hướng đi nhưng chưa hài lòng lắm nên gửi lên đây nhờ các bạn tư vấn xem có cách gì hay không (miễn đở tốn công là được)

 

[ndu96081631]

Hic... mình hỏi xong chắc mình phải tự "cày" luôn quá
Buồn...

 

[Hai Lúa Miền Tây]

Em nghĩ dùng vòng lặp, duyệt qua từng cell chứa hình, chụp hình nó lại, lưu vào ổ đĩa với tên là địa chỉ cell tương ứng, sau đó load hình đó vào comment, sau cùng là xóa hình ở ổ điã.

 

[OverAC]

Em nghĩ dùng vòng lặp, duyệt qua từng cell chứa hình, chụp hình nó lại, lưu vào ổ đĩa với tên là địa chỉ cell tương ứng, sau đó load hình đó vào comment, sau cùng là xóa hình ở ổ điã.

Mở file đó ra bằng đường zip. rồi load lên được không?

 

[ndu96081631]

Mở file đó ra bằng đường zip. rồi load lên được không?

Nghĩa là sao hả Bình
Mở file bằng ZIP rồi làm sao nữa? Load lên là load làm sao?

 

[OverAC]

ý em là đổi đuôi file thành zip vào media copy hình ra folder nào đó rồi cho code import hình vào comment. Tất nhiên là vì các hình nó được đặt tên theo tiêu chuẩn nào đó để mình add vào đúng vị trí.

Sub Macro2()
For i = 1 To 4
    Range("A" & i + 1).AddComment
    Range("A" & i + 1).Comment.Visible = False
    Range("A" & i + 1).Comment.Shape.Fill.UserPicture "D:\Binh\media\image" & i & ".JPG"
Next i
End Sub

 

[ndu96081631]

ý em là đổi đuôi file thành zip vào media copy hình ra folder nào đó rồi cho code import hình vào comment. Tất nhiên là vì các hình nó được đặt tên theo tiêu chuẩn nào đó để mình add vào đúng vị trí.

Sub Macro2()
For i = 1 To 4
    Range("A" & i + 1).AddComment
    Range("A" & i + 1).Comment.Visible = False
    Range("A" & i + 1).Comment.Shape.Fill.UserPicture "D:\Binh\media\image" & i & ".JPG"
Next i
End Sub

Việc lấy hình ra đúng là không có vấn đề gì (dùng cách của Bình cũng được)
Vấn đề là làm sao biết hình nào nằm ở cell nào để Add Comment cho đúng vị trí ấy chứ

 

[Hai Lúa Miền Tây]

Em làm theo bước em nói như trên như sau:

Sub ChenHinh()
Dim sFile As String, cll As Range
Dim chtObj As ChartObject
On Error Resume Next
Kill sFile
On Error GoTo 0
For Each cll In Range("b2:b5")
    On Error Resume Next
    sFile = "c:\" & cll.Row & ".gif"
    cll.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Set chtObj = ActiveSheet.ChartObjects.Add( _
    cll.Left, cll.Top, cll.Width, cll.Height)
    With chtObj
        .Chart.Paste
        .Chart.Export sFile
        .Delete
    End With
    With Range("B" & cll.Row)
        .Comment.Delete
        .AddComment
        .Comment.Visible = False
        .Comment.Shape.Fill.UserPicture sFile
    End With
    Kill sFile
Next
End Sub

 

[ndu96081631]

Em làm theo bước em nói như trên như sau:

Sub ChenHinh()
Dim sFile As String, cll As Range
Dim chtObj As ChartObject
On Error Resume Next
Kill sFile
On Error GoTo 0
For Each cll In Range("b2:b5")
    On Error Resume Next
    sFile = "c:\" & cll.Row & ".gif"
    cll.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    Set chtObj = ActiveSheet.ChartObjects.Add( _
    cll.Left, cll.Top, cll.Width, cll.Height)
    With chtObj
        .Chart.Paste
        .Chart.Export sFile
        .Delete
    End With
    With Range("B" & cll.Row)
        .Comment.Delete
        .AddComment
        .Comment.Visible = False
        .Comment.Shape.Fill.UserPicture sFile
    End With
    Kill sFile
Next
End Sub

Dựa vào code trên, tôi sửa lại thế này:

Function ShapeRange(ByVal shp As Object) As Range
  On Error Resume Next
  Set ShapeRange = shp.Parent.Range(shp.TopLeftCell, shp.BottomRightCell)
End Function
Sub ChenHinh()
  Dim sFile As String, cll As Range
  Dim pic As Picture
  Dim chtObj As ChartObject
  On Error Resume Next
  For Each pic In ActiveSheet.Pictures
    Set cll = ShapeRange(pic)
    sFile = "c:\" & cll.Address & ".bmp"
    pic.CopyPicture xlScreen, xlBitmap
    Set chtObj = ActiveSheet.ChartObjects.Add(cll.Left, cll.Top, cll.Width, cll.Height)
    With chtObj
      .Chart.Paste
      .Chart.Export sFile
      .Delete
    End With
    cll.Cells(1, 1).Comment.Delete
    cll.Cells(1, 1).AddComment
    With cll.Cells(1, 1).Comment.Shape
      .Visible = True
      .Shadow.Visible = msoFalse
      .Line.Visible = msoFalse
      .AutoShapeType = msoShapeRectangle
      .LockAspectRatio = False
      .Left = cll.Left: .Top = cll.Top
      .Width = cll.Width: .Height = cll.Height
      .Fill.UserPicture sFile   
    End With
    pic.Delete
    Kill sFile
  Next
End Sub

Nhưng chạy xong thấy nó.. sao sao ấy. Cái hình chèn vào hình như bị méo thì phải (chẳng biết sao nữa)
Để nghiên cứu lại xem
-------------------------
Ah...
Phát hiện ra cái hình bị méo là do Export từ chart mà ra. Hic... Đuối thiệt

 

[Hai Lúa Miền Tây]

Chỉ còn cách này thôi Thầy à, nhân tiện đây em xin hỏi là có cách nào lấy hình trong clipboard đưa vào comment không?

 

[nghiaphuc]

Việc lấy hình ra đúng là không có vấn đề gì (dùng cách của Bình cũng được)
Vấn đề là làm sao biết hình nào nằm ở cell nào để Add Comment cho đúng vị trí ấy chứ

Cái này thì mình có thể dựa vào thuộc tính Shape.TopLeftCell được mà anh.

 

[ndu96081631]

nhân tiện đây em xin hỏi là có cách nào lấy hình trong clipboard đưa vào comment không?

Nhắc mới nhớ là có:
http://www.giaiphapexcel.com/forum/...Sheet-lên-Button-của-Form&p=458257#post458257
Nhưng không phải là lấy từ clipboard đưa vào comment mà lấy tự clipboard chuyển thành dạng IPictureDisp ---> Từ cái này, thích làm gì cũng vô tư (save thành file chẳng hạn)
-----------------------------------------------------
Để nghiên cứu... lát nữa sẽ có kết quả
-----------------------------------------------------

Cái này thì mình có thể dựa vào thuộc tính Shape.TopLeftCell được mà anh.

Thì mình đã áp dụng ở bài 9 đấy thôi

 

[ndu96081631]

Nhắc mới nhớ là có:
http://www.giaiphapexcel.com/forum/...Sheet-lên-Button-của-Form&p=458257#post458257
Nhưng không phải là lấy từ clipboard đưa vào comment mà lấy tự clipboard chuyển thành dạng IPictureDisp ---> Từ cái này, thích làm gì cũng vô tư (save thành file chẳng hạn)
-----------------------------------------------------
Để nghiên cứu... lát nữa sẽ có kết quả
-----------------------------------------------------


Thì mình đã áp dụng ở bài 9 đấy thôi

Xong!
Function PictureFromObject lấy ở bài bên kia. Thêm đoạn code này vào:

Function ShapeRange(ByVal shp As Object) As Range
  On Error Resume Next
  Set ShapeRange = shp.Parent.Range(shp.TopLeftCell, shp.BottomRightCell)
End Function
Sub Main()
  Dim shp As Picture, rng As Range, IPic As IPictureDisp
  Dim fileName As String, n As Long
  For Each shp In Sheet1.Pictures
    n = n + 1
    Set rng = ShapeRange(shp)
    Set IPic = PictureFromObject(shp)
    fileName = CreateObject("Scripting.FileSystemObject").GetTempName
    SavePicture IPic, fileName
    On Error Resume Next
    With rng.Cells(1, 1)
      .Comment.Delete
      On Error GoTo 0
      .AddComment
      With .Comment.Shape
        .Shadow.Visible = msoFalse
        .Line.Visible = msoFalse
        .AutoShapeType = msoShapeRectangle
        .Left = rng.Left: .Top = rng.Top: .Visible = True
        .Width = rng.Width: .Height = rng.Height
        .Fill.UserPicture fileName
      End With
    End With
    Kill fileName
    shp.Delete
  Next
  If n Then MsgBox "Done!"
End Sub

Chạy Sub Main là ra kết quả
Cũng khoai thiệt! (may có Hai Lúa nhắc nhở vụ Clipboard. Cảm ơn hen!)

 

[Hai Lúa Miền Tây]

Cũng khoai thiệt! (may có Hai Lúa nhắc nhở vụ Clipboard. Cảm ơn hen!)

Em định đi hướng này, test mãi chẳng được. Nhớ có đọc đâu đó rồi mà tìm hong có ra.