Sửa code chèn hình ảnh vào excel

[tranductuyen1984]

Chào các bạn
Mình đã tìm hiểu về vấn đề chèn hình ảnh từ floder vào trong excel rất hay và có dowload về được một file tham khảo (đính kèm). Tuy nhiên nó chưa thực sự hữu dụng cho mình lắm nên mạo muội nhờ các bạn trên diễn đàn sửa giùm với nội dung như sau: Chèn hình hảnh theo hàng chứ không theo cột (từ hàng thứ 6 trở xuống), khi thay đổi mã số thì các hình ảnh cũ sẽ bị xóa hết. Rất mong các bạn giúp đỡ
Tks!

 

[jack nt]

code của bạn

Private Sub CHENHINH_Click()
Dim r, n
Dim Pic As String
Application.Calculation = 3
Application.ScreenUpdating = False
On Error Resume Next
Columns(2).ColumnWidth = [F2]
    n = [A65536].End(3).Row
        For r = 2 To n
            Pic = Cells(r, 1).Value & ".jpg"
                Shapes(Pic).Delete
                Rows(r).RowHeight = [H2]
            With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Pic)
                .Name = Pic
                .Left = Cells(r, 2).Left: .Top = Cells(r, 2).Top
                [COLOR=#ff0000].Width = Cells(r, 2).Width[/COLOR]: .Height = Cells(r, 2).Height
            End With
        Next
Application.ScreenUpdating = True
Application.Calculation = 1
End Sub

1. chỗ tô màu đỏ là thừa, vì khi bạn điều chỉnh Height thì Width sẽ tự động chỉnh theo, cho nên không thể khớp cả dòng lẫn cột.
2. muốn chỉnh theo dòng thì đổi Column thành Row, Height thành Width, r thành c, Cells(r, 2) thành Cells(6, c), đại loại vậy.
3. không hiểu "khi thay đổi mã số thì các hình ảnh cũ sẽ bị xóa hết" là sao. mã số là tên hình hay cái gì???
4. tui có giải pháp xếp nối đuôi theo hàng/ cột, nếu bạn thích sẽ gởi lên.

 

[tranductuyen1984]

jack nt
1. chỗ tô màu đỏ là thừa, vì khi bạn điều chỉnh Height thì Width sẽ tự động chỉnh theo, cho nên không thể khớp cả dòng lẫn cột.
2. muốn chỉnh theo dòng thì đổi Column thành Row, Height thành Width, r thành c, Cells(r, 2) thành Cells(6, c), đại loại vậy.
3. không hiểu "khi thay đổi mã số thì các hình ảnh cũ sẽ bị xóa hết" là sao. mã số là tên hình hay cái gì???
4. tui có giải pháp xếp nối đuôi theo hàng/ cột, nếu bạn thích sẽ gởi lên.



Cái này mình đã đổi thử nhưng không được như bạn nói, mình up lại file và có ghi rõ nội dung, mong bạn xem và chỉnh giùm. Bạn có nói là có thể nối ảnh theo hàng hay theo cột thì bạn cho mình xin luôn nhé.
Tks!

 

[jack nt]

Cái này mình đã đổi thử nhưng không được như bạn nói, mình up lại file và có ghi rõ nội dung, mong bạn xem và chỉnh giùm. Bạn có nói là có thể nối ảnh theo hàng hay theo cột thì bạn cho mình xin luôn nhé.
Tks!

đã sửa hộ bạn

Private Sub CHENHINH2_Click()
    Dim c As Integer, n As Integer
    Dim Pic As String
    Application.Calculation = 3
    Application.ScreenUpdating = False
    On Error Resume Next
    n = [IV10].End(1).Column
    xoaHinhTrenDong 11
    For c = 2 To n
        If Cells(10, c) <> vbNullString Then
            Pic = Cells(10, c).Value & ".jpg"
            With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Pic)
                .Name = Pic
                .Left = Cells(11, c).Left
                .Top = Cells(11, c).Top
                .Height = Cells(11, c).Height
            End With
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = 1
End Sub

và bổ sung phần xóa hình cũ

Private Sub xoaHinhTrenDong(k As Integer)
    Dim Shp As Shape, T As Single, H As Single
    With Rows(k)
        T = .Top: H = Rows(k).Height
    End With
    For Each Shp In Shapes
        With Shp.TopLeftCell
            If .Top >= T And .Top < T + H Then
                Shp.Delete
            End If
        End With
    Next
End Sub

code chèn hình nối đuôi trên dòng/cột

Public Sub InsertPictureToColumn(Sh As Object, RngPicture As Range, PreName$, NextPictureTop!, PictureFullName$, _
Optional StrHyperLink$, Optional StrScreenTip$, Optional CountPictures&, Optional kZoom!, Optional FlagCenter As Boolean)
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim MyPicture As Object, PicName$
    If kZoom <= 0 Then kZoom = 100
    Sh.Unprotect
    With Sh.Pictures.Insert(PictureFullName)
        .Name = PreName & Format(CountPictures, "00")
        .Top = NextPictureTop + 0.75
        .Left = RngPicture.Left + 0.75
        .Width = kZoom / 100 * RngPicture.Width - 0.75
        If FlagCenter Then
            If .Height > RngPicture.Height Then
                .Height = RngPicture.Height
            ElseIf .Height < RngPicture.Height Then
                .Top = RngPicture.Top + (RngPicture.Height - .Height) / 2
            End If
            .Left = RngPicture.Left + (RngPicture.Width - .Width) / 2
        End If
        NextPictureTop = NextPictureTop + .Height + 0.75
        If StrHyperLink <> vbNullString Then
            Sh.Hyperlinks.Add Anchor:=Sh.Shapes(.Name), Address:=StrHyperLink, ScreenTip:=StrScreenTip
        End If
    End With
End Sub


Public Sub InsertPictureToRow(Sh As Object, RngPicture As Range, PreName$, NextPictureLeft!, PictureFullName$, _
Optional StrHyperLink$, Optional StrScreenTip$, Optional CountPictures&, Optional kZoom!, Optional FlagCenter As Boolean)
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim MyPicture As Object, PicName$
    If kZoom <= 0 Then kZoom = 100
    Sh.Unprotect
    With Sh.Pictures.Insert(PictureFullName)
        .Name = PreName & Format(CountPictures, "00")
        .Left = NextPictureLeft + 0.75
        .Top = RngPicture.Top + 0.75
        .Height = kZoom / 100 * RngPicture.Height - 0.75
        If FlagCenter Then
            If .Width > RngPicture.Width Then
                .Width = RngPicture.Width
                .Top = RngPicture.Top + (RngPicture.Height - .Height) / 2
            ElseIf .Width < RngPicture.Width Then
                .Height = RngPicture.Height
                .Left = RngPicture.Left + (RngPicture.Width - .Width) / 2
            End If
        End If
        NextPictureLeft = NextPictureLeft + .Width + 0.75
        If StrHyperLink <> vbNullString Then
            Sh.Hyperlinks.Add Anchor:=Sh.Shapes(.Name), Address:=StrHyperLink, ScreenTip:=StrScreenTip
        End If
    End With
End Sub

P/S: cái này ngoài chèn hình còn chèn hyperlink, screentip, zoom và canh lề giữa

 

[tranductuyen1984]

Cảm ơn bạn nhiều nhé. Phần nối hình theo hàng hay theo cột của bạn mình thấy chỉ thấy chạy dược ở hàng 10 thôi, và chỉ update được dạng jpg, trong khi ảnh của minh dạng tif. Thêm một điều nữa là m ko thấy zoom chỗ nào cả (thông cảm mình chưa biết nhiều về vba)