Do code của bạn dùng Pictures.Insert nên khi lưu tập tin -> đóng tập tin -> xóa ảnh trên đĩa -> mở lại tập tin thì sẽ có như trong ảnh đính kèm. Tức không được xóa ảnh trên đĩa, không được chuyển sang chỗ khác. Lý do là ảnh không được nhập vào hẳn mà chỉ được kết nối thôi.
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
Sub LayAnh()
Dim filename As String
filename = Browse_PICFILE
If Len(filename) Then InsertPicture filename, range("E2")
End Sub
3. Trong sub LuuAnh thay
ActiveSheet.Shapes.Range(Array([E2])).Select
bằng
ActiveSheet.Shapes.range("$E$2").Select
Bây giờ em sử dụng nút xoá ảnh để xoá các ảnh trong sheet 1 trở đi thì thay như thế nào ạ.
ví dụ em muốn xoá hàng loạt ảnh của vùng AW4 từ sheet 1->sheet 5
Anh hướng dẫn em với ạ. em mong muốn code chỉ định rõ số sheet có ảnh mình cần xoá hàng loạt ạ./
Sub DeleteSelectedPic()
Dim k As Long, sh As Worksheet, shp As Shape, Arr()
ReDim Arr(1 To ActiveWindow.SelectedSheets.Count)
For k = 1 To UBound(Arr)
Arr(k) = ActiveWindow.SelectedSheets(k).Name
Next k
ThisWorkbook.Worksheets("Nhap anh").Select
For k = 1 To UBound(Arr)
Set sh = ThisWorkbook.Worksheets(Arr(k))
For Each shp In sh.Shapes
If shp.TopLeftCell.Address = "$AW$4" Then
shp.Delete
Exit For
End If
Next shp
Next k
End Sub
2. Thao tác: Trên thanh "Sheets tab" chọn các sheet cần xóa ảnh -> chạy sub DeleteSelectedPic. Vd. bạn có sheet 1 đến 200 nhưng bạn chỉ muốn xóa ảnh trong 1, 2, 3, 12 thì bạn chỉ chọn 4 sheet đó rồi chạy sub DeleteSelectedPic (có thể gán macro DeleteSelectedPic cho nút nào đấy)
Do code của bạn dùng Pictures.Insert nên khi lưu tập tin -> đóng tập tin -> xóa ảnh trên đĩa -> mở lại tập tin thì sẽ có như trong ảnh đính kèm. Tức không được xóa ảnh trên đĩa, không được chuyển sang chỗ khác. Lý do là ảnh không được nhập vào hẳn mà chỉ được kết nối thôi.
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
Sub LayAnh()
Dim filename As String
filename = Browse_PICFILE
If Len(filename) Then InsertPicture filename, range("E2")
End Sub
3. Trong sub LuuAnh thay
ActiveSheet.Shapes.Range(Array([E2])).Select
bằng
ActiveSheet.Shapes.range("$E$2").Select
1. Thêm code
Mã:
Sub DeleteSelectedPic()
Dim k As Long, sh As Worksheet, shp As Shape, Arr()
ReDim Arr(1 To ActiveWindow.SelectedSheets.Count)
For k = 1 To UBound(Arr)
Arr(k) = ActiveWindow.SelectedSheets(k).Name
Next k
ThisWorkbook.Worksheets("Nhap anh").Select
For k = 1 To UBound(Arr)
Set sh = ThisWorkbook.Worksheets(Arr(k))
For Each shp In sh.Shapes
If shp.TopLeftCell.Address = "$AW$4" Then
shp.Delete
Exit For
End If
Next shp
Next k
End Sub
2. Thao tác: Trên thanh "Sheets tab" chọn các sheet cần xóa ảnh -> chạy sub DeleteSelectedPic. Vd. bạn có sheet 1 đến 200 nhưng bạn chỉ muốn xóa ảnh trong 1, 2, 3, 12 thì bạn chỉ chọn 4 sheet đó rồi chạy sub DeleteSelectedPic (có thể gán macro DeleteSelectedPic cho nút nào đấy)
Bác bên trên hướng dẫn bạn dùng DeleteSelectedPic() rồi mà???
Thêm nữa, ở #12, mình đã hỏi bạn là muốn xóa 1 hay tất cả các ảnh thì bạn không trả lời???
Bác bên trên hướng dẫn bạn dùng DeleteSelectedPic() rồi mà???
Thêm nữa, ở #12, mình đã hỏi bạn là muốn xóa 1 hay tất cả các ảnh thì bạn không trả lời???
Do code của bạn dùng Pictures.Insert nên khi lưu tập tin -> đóng tập tin -> xóa ảnh trên đĩa -> mở lại tập tin thì sẽ có như trong ảnh đính kèm. Tức không được xóa ảnh trên đĩa, không được chuyển sang chỗ khác. Lý do là ảnh không được nhập vào hẳn mà chỉ được kết nối thôi.
Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
Optional original As Boolean = False, Optional center As Boolean = False, _
Optional LinkToFile As Boolean = False)
' Target: vung nhap anh. Co the la nhieu cell
' Neu Target = Nothing thi Target = ActiveCell
' Neu original = True thi nhap anh kich thuoc thuc.
' Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
' nguoc lai thi se vua khit vung Target
' LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
If Target Is Nothing Then Set Target = ActiveCell
On Error Resume Next
Target.Parent.Shapes(Target.Address).Delete
On Error GoTo 0
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(PicFilename) Then
If LinkToFile Then
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
Else
Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
End If
If Not shp Is Nothing Then
With shp
If original Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
ElseIf center Then
.ScaleWidth 1, msoTrue
.ScaleHeight 1, msoTrue
w = Target.Width
h = w * .Height / .Width
If h > Target.Height Then
h = Target.Height
w = h * .Width / .Height
End If
.left = Target.left + (Target.Width - w) / 2
.top = Target.top + (Target.Height - h) / 2
.Width = w
.Height = h
Else
.Width = Target.Width
.Height = Target.Height
End If
shp.Name = Target.Address
shp.Placement = xlMoveAndSize
End With
End If
End If
Set fso = Nothing
End Sub
Sub LayAnh()
Dim filename As String
filename = Browse_PICFILE
If Len(filename) Then InsertPicture filename, range("E2")
End Sub
3. Trong sub LuuAnh thay
ActiveSheet.Shapes.Range(Array([E2])).Select
bằng
ActiveSheet.Shapes.range("$E$2").Select
1. Thêm code
Mã:
Sub DeleteSelectedPic()
Dim k As Long, sh As Worksheet, shp As Shape, Arr()
ReDim Arr(1 To ActiveWindow.SelectedSheets.Count)
For k = 1 To UBound(Arr)
Arr(k) = ActiveWindow.SelectedSheets(k).Name
Next k
ThisWorkbook.Worksheets("Nhap anh").Select
For k = 1 To UBound(Arr)
Set sh = ThisWorkbook.Worksheets(Arr(k))
For Each shp In sh.Shapes
If shp.TopLeftCell.Address = "$AW$4" Then
shp.Delete
Exit For
End If
Next shp
Next k
End Sub
2. Thao tác: Trên thanh "Sheets tab" chọn các sheet cần xóa ảnh -> chạy sub DeleteSelectedPic. Vd. bạn có sheet 1 đến 200 nhưng bạn chỉ muốn xóa ảnh trong 1, 2, 3, 12 thì bạn chỉ chọn 4 sheet đó rồi chạy sub DeleteSelectedPic (có thể gán macro DeleteSelectedPic cho nút nào đấy)
Cuối cùng có <vùng cần nhập ảnh> = <ô chứa đường dẫn tới ảnh ở cột A hoặc D>.Offset(-1, 1).MergeArea
------------
Những cái tôi viết ở trên nó chẳng liên quan gì tới nhập ảnh. Những cái đó là lập trình VBA, là cách viết code, là kinh nghiệm ...
Tóm lại là:
1. Code cho trường hợp cụ thể này, chỉ có 4 ảnh trong mỗi cột.
Mã:
Sub Nhap_sheet1()
Dim k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
For k = 1 To 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
2. Code cho trường hợp TỔNG QUÁT, khi số ảnh hiện hành tùy ý, nhưng đường dẫn cũng ở các dòng có chỉ số là bội của 4, tức 4*k, và ở cột A và D
Mã:
Sub Nhap_sheet1()
Dim lastRow As Long, k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
lastRow = Sheet1.Cells(Rows.Count, c).End(xlUp).Row
For k = 1 To lastRow \ 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
Cuối cùng có <vùng cần nhập ảnh> = <ô chứa đường dẫn tới ảnh ở cột A hoặc D>.Offset(-1, 1).MergeArea
------------
Những cái tôi viết ở trên nó chẳng liên quan gì tới nhập ảnh. Những cái đó là lập trình VBA, là cách viết code, là kinh nghiệm ...
Tóm lại là:
1. Code cho trường hợp cụ thể này, chỉ có 4 ảnh trong mỗi cột.
Mã:
Sub Nhap_sheet1()
Dim k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
For k = 1 To 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
2. Code cho trường hợp TỔNG QUÁT, khi số ảnh hiện hành tùy ý, nhưng đường dẫn cũng ở các dòng có chỉ số là bội của 4, tức 4*k, và ở cột A và D
Mã:
Sub Nhap_sheet1()
Dim lastRow As Long, k As Long, c As Long
For c = 1 To 4 Step 3 ' c = 1 -> cot A, c = 4 -> cot D
lastRow = Sheet1.Cells(Rows.Count, c).End(xlUp).Row
For k = 1 To lastRow \ 4
If Len(Sheet1.Cells(4 * k, c).Value) Then
' duong dan khong rong -> nhap anh
InsertPicture ThisWorkbook.Path & "\" & Sheet1.Cells(4 * k, c).Value & ".jpg", Sheet1.Cells(4 * k, c).Offset(-1, 1).MergeArea
End If
Next k
Next c
End Sub
)
