Hỏi đáp về hàm lấy ảnh bằng VBA

[beetune1991]

Kính gửi anh chị,

em có một file như đính kèm.
Hiện tại thao tác em thực hiện sẽ theo thứ từ
1. chọn số sheet
2. lấy ảnh
3. lưu ảnh
4. xóa ảnh

do có quá nhiều bước nên em muốn bỏ đi bước 1 và bước 4 tích hợp trong trước 3. lưu ảnh
Khi ấn số 3 lưu ảnh thì ảnh cũng tự động xóa đi và số sheet cũng tự động nhảy lên theo thứ tự mặc định của số ban đầu nếu là số 1 sẽ là 2,3,4,5,6
Nếu mặc định ban đầu e ghi là số 5 thì tự động nhảy lên 6,7,8,9,10

Anh chị giúp em với ạ

 

[befaint]

do có quá nhiều bước nên em muốn bỏ đi bước 1 và bước 4 tích hợp trong trước 3. lưu ảnh

Trong file có miếng code nào đâu bạn?

Dùng .Add thì mới lưu ảnh theo tập tin được.


Mà chưa rõ ai hỏi, ai đáp đây bạn?

 

[beetune1991]

Trong file có miếng code nào đâu bạn?

Dùng .Add thì mới lưu ảnh theo tập tin được.
View attachment 255161

Mà chưa rõ ai hỏi, ai đáp đây bạn?

View attachment 255162

Trong file có miếng code nào đâu bạn?

Dùng .Add thì mới lưu ảnh theo tập tin được.
View attachment 255161

Mà chưa rõ ai hỏi, ai đáp đây bạn?

View attachment 255162

em gửi nhầm file ạ. file mới em gửi update lại vào bài rồi ạ.

 

[lubu08]

hình như bạn muốn tự động tạo CV à?
sao không làm tool chạy cả danh sách (điều kiện: ảnh được đặt tên theo quy tắc, ví dụ: stt-tên -> 1.Nguyễn Văn A.xlsx) ?
làm như vậy sẽ không mất công chọn ảnh (nhưng mất công sửa tên file ảnh) và tạo ra sheet theo stt luôn.

 

[beetune1991]

hình như bạn muốn tự động tạo CV à?
sao không làm tool chạy cả danh sách (điều kiện: ảnh được đặt tên theo quy tắc, ví dụ: stt-tên -> 1.Nguyễn Văn A.xlsx) ?
làm như vậy sẽ không mất công chọn ảnh (nhưng mất công sửa tên file ảnh) và tạo ra sheet theo stt luôn.

dạ không cái đó em biết làm rồi ạ.
hiện tại thì em đang làm cái này ạ. nhưng nhiều bước quá nên em muốn nhờ các anh chị chỉnh giúp em giản lược đi 2 bước ạ.

 

[lubu08]

thế thì như này:
-theo mình để 1 sheet là CV
-khi lấy ảnh, copy sheet CV đó, đổi tên sheet rồi chèn ảnh vào (vậy là khỏi lo xóa ảnh)
muốn stt tăng thì để 1 biến truyền vào thôi

    Sheets("CV").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = ten

 

[beetune1991]

thế thì như này:
-theo mình để 1 sheet là CV
-khi lấy ảnh, copy sheet CV đó, đổi tên sheet rồi chèn ảnh vào (vậy là khỏi lo xóa ảnh)
muốn stt tăng thì để 1 biến truyền vào thôi

    Sheets("CV").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = ten

làm theo file trên ko được à anh

 

[lubu08]

làm theo file trên ko được à anh

Bạn thử chạy theo code này xem
(phần kích thước ảnh bạn phải tự căn chỉnh lại)

Sub bPic()
    Dim nameSheet As Integer, addressPic As String
    Dim p As Object
   
    nameSheet = Sheets("Nhap Anh").Range("B1").Value
    addressPic = Browse_PICFILE
   
    Sheets("CV").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = nameSheet
   
    Set p = ActiveSheet.Shapes.AddPicture(addressPic, True, True, 0, 0, 353, 117)
    With p
        .Left = Range("A1").Left + (Range("A1:B1").Width - 353) / 2
        .Top = Range("A1").Top + (Range("A1:B1").Height - 100) / 2
    End With
    Sheets("Nhap Anh").Range("B1") = nameSheet + 1
End Sub

Còn đây là code xóa toàn bộ ảnh trong sheet

Sheets("Nhap anh").DrawingObjects.Delete

 

[beetune1991]

Bạn thử chạy theo code này xem
(phần kích thước ảnh bạn phải tự căn chỉnh lại)

Sub bPic()
    Dim nameSheet As Integer, addressPic As String
    Dim p As Object
  
    nameSheet = Sheets("Nhap Anh").Range("B1").Value
    addressPic = Browse_PICFILE
  
    Sheets("CV").Copy After:=Sheets(Sheets.Count)
    ActiveSheet.Name = nameSheet
  
    Set p = ActiveSheet.Shapes.AddPicture(addressPic, True, True, 0, 0, 353, 117)
    With p
        .Left = Range("A1").Left + (Range("A1:B1").Width - 353) / 2
        .Top = Range("A1").Top + (Range("A1:B1").Height - 100) / 2
    End With
    Sheets("Nhap Anh").Range("B1") = nameSheet + 1
End Sub

Còn đây là code xóa toàn bộ ảnh trong sheet

Sheets("Nhap anh").DrawingObjects.Delete

em chạy không được
ý em là khi ấn nút "lưu ảnh" bước 2 thì bước 1 và bước 4 thực điện đồng thời ấy ạ. vừa nhảy số thứ tự vừa xóa ảnh vừa lưu

 

[lubu08]

Bạn thử xem đúng ý bạn chưa?
(mấy phần bẫy lỗi và căn chỉnh tự làm nhé)

 

[beetune1991]

Bạn thử xem đúng ý bạn chưa?
(mấy phần bẫy lỗi và căn chỉnh tự làm nhé)

Em hiểu ý của anh. Nhưng các sheet 1,2,3 là các sheet có sẵn ạ. không phải tạo từ CV gốc.
File gốc chỉ cần nhảy số ở bước 1 là nó sẽ tự động nhảy ảnh vào các sheet đó ạ.
e thấy bước 4 đã được giản lướt rồi ạ
Anh giúp em thêm vụ bước một tự nhảy 1,2,3,4 theo thứ tự setupban đầu khi ấn bước 3 Lưu ảnh đi ạ.

Bài đã được tự động gộp: 11/3/21

Bạn thử xem đúng ý bạn chưa?
(mấy phần bẫy lỗi và căn chỉnh tự làm nhé)

Thêm nữa là code của em đang cop size chỉnh ảnh theo khung của các sheet. anh tiện sửa giúp em với ạ. đừng để nó copy size lung tung với ạ.

 

[lubu08]

@@ sao từ đầu bạn không nói rõ là các sheet đã có sẵn?
Mà bản mình gửi đã tự tăng stt lên 1 rồi mà??

tự nhảy 1,2,3,4 theo thứ tự setupban đầu khi ấn bước 3 Lưu ảnh

Mình xác nhận lại vấn đề của bạn nhớ.
File của bạn có nhiều sheets giống nhau, mỗi sheets CHỈ có MỘT ảnh ở ô "AW4".
Sheet "Nhap Anh" sẽ điều khiển để thay ảnh ở sheet được chọn.
Thay ảnh theo quy trình: chọn ảnh -> xóa ảnh cũ -> thay ảnh mới
Sau khi thay ảnh, stt sẽ tăng lên 1.

 

[batman1]

em có một file như đính kèm.
Hiện tại thao tác em thực hiện sẽ theo thứ từ
1. chọn số sheet
2. lấy ảnh
3. lưu ảnh
4. xóa ảnh

Nếu vẫn dùng code của bạn thì trong Sub LuuAnh trước dòng MsgBox "Xong!" bạn thêm 2 dòng

DeletePics
Range("B1").Value = Range("B1").Value + 1

 

[beetune1991]

@@ sao từ đầu bạn không nói rõ là các sheet đã có sẵn?
Mà bản mình gửi đã tự tăng stt lên 1 rồi mà??

Mình xác nhận lại vấn đề của bạn nhớ.
File của bạn có nhiều sheets giống nhau, mỗi sheets CHỈ có MỘT ảnh ở ô "AW4".
Sheet "Nhap Anh" sẽ điều khiển để thay ảnh ở sheet được chọn.
Thay ảnh theo quy trình: chọn ảnh -> xóa ảnh cũ -> thay ảnh mới
Sau khi thay ảnh, stt sẽ tăng lên 1.

Vâng để "Nhập ảnh" hay "Lưu ảnh" điều khiển đều được anh ạ.
Miễn sao khi ấn nút ấy sẽ giản lước bước tăng số sheet và bước xoá ảnh ạ

 

[beetune1991]

Nếu vẫn dùng code của bạn thì trong Sub LuuAnh trước dòng MsgBox "Xong!" bạn thêm 2 dòng

DeletePics
Range("B1").Value = Range("B1").Value + 1

Anh ơi phân vùng chỉ định xoá ảnh thì thêm gì nữa ạ

 

[batman1]

Anh ơi phân vùng chỉ định xoá ảnh thì thêm gì nữa ạ

Tôi là người chậm hiểu nên không hiểu "phân vùng chỉ định xoá ảnh" là gì.

Muốn gì thì mô tả kỹ thôi.

 

[beetune1991]

Tôi là người chậm hiểu nên không hiểu "phân vùng chỉ định xoá ảnh" là gì.

Muốn gì thì mô tả kỹ thôi.

Trong code xoá ảnh của em có chỉ rõ vùng cần xoá là từ E2:F2 đấy ạ

 

[batman1]

Trong code xoá ảnh của em có chỉ rõ vùng cần xoá là từ E2:F2 đấy ạ

Bởi vì bạn viết là code đã hoạt động nên tôi không kiểm tra kỹ. Nhưng giờ thấy không có E2:F2, chỉ thấy E2:E3?

Sub DeletePics()
Dim shp As Shape
Set ws = ActiveSheet
Set Rng = ws.range("E2:E3")
...
End Sub

Nhưng tôi không hiểu. Nhấn nút "Lấy ảnh" thì nhập ảnh vào E2. Trong E3, F2 làm gì có ảnh mà xóa?

Tóm lại DELETE tất cả mọi thứ chỉ chừa lại 2 nút "Lấy ảnh" và "Lưu ảnh vào CV". Ảnh sẽ được nhập vào E2 khi nhấn nút Lấy và được xóa khỏi E2 khi nhấn Lưu. E3, F2 không có gì cả.



Tuy nhiên tôi đề nghị xóa bỏ sub DeletePics và trong sub LuuAnh trước dòng MsgBox "Xong!" thì thêm

On Error Resume Next
ActiveSheet.Shapes(range("E2").Value).Delete
On Error GoTo 0
range("B1").Value = range("B1").Value + 1

Dùng On Error ... chỉ để đề phòng ai đó đã xóa ảnh bằng tay trước khi nhấn nút "Lưu ..."

 

[beetune1991]

Bởi vì bạn viết là code đã hoạt động nên tôi không kiểm tra kỹ. Nhưng giờ thấy không có E2:F2, chỉ thấy E2:E3?


Nhưng tôi không hiểu. Nhấn nút "Lấy ảnh" thì nhập ảnh vào E2. Trong E3, F2 làm gì có ảnh mà xóa?

Tóm lại DELETE tất cả mọi thứ chỉ chừa lại 2 nút "Lấy ảnh" và "Lưu ảnh vào CV". Ảnh sẽ được nhập vào E2 khi nhấn nút Lấy và được xóa khỏi E2 khi nhấn Lưu. E3, F2 không có gì cả.

View attachment 255271

Tuy nhiên tôi đề nghị xóa bỏ sub DeletePics và trong sub LuuAnh trước dòng MsgBox "Xong!" thì thêm

On Error Resume Next
ActiveSheet.Shapes(range("E2").Value).Delete
On Error GoTo 0
range("B1").Value = range("B1").Value + 1

Dùng On Error ... chỉ để đề phòng ai đó đã xóa ảnh bằng tay trước khi nhấn nút "Lưu ..."

Chạy được rồi anh ạ. nhưng anh cho em hỏi nó hiện lên như thế này có vấn đề gì không ạ

Bài đã được tự động gộp: 12/3/21

Sub DeletePics()
Dim shp As Shape
Set ws = ActiveSheet
Set Rng = ws.Range("E2:E3")
Application.ScreenUpdating = False
For Each shp In ws.Shapes
With shp
If .Name Like "Picture*" Then
s = .TopLeftCell.Address & ":" & .BottomRightCell.Address
If Not Intersect(Rng, ws.Range(s)) Is Nothing Then
shp.Delete
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub

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

 

[lubu08]

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

Code để xóa ảnh theo ý bạn đây

    For i = 1 To 5
        Sheets(CStr(i)).DrawingObjects.Delete
    Next i