Tự động đặt pass cho nhiều file words theo list excel

Chia sẻ bởi:hands

★★★★★

‹ Tự động đặt pass hoặc xóa cho... Save file word sang pdf nhanh ›

Quảng cáo

Em chào các anh chị,
Em có 1 folder nhiều file word khác nhau, em muốn đặt pass cho mỗi file word là 1 pass khác nhau theo list excel cho sẵn.
Dữ liệu điều kiện đặt pass như sau :
– Cột A2 là tên file Word
– Cột B2 là pass tương ứng.
Mong các anh chị giúp đỡ em. Em cám ơn ạ.

Lưu ý:
1. Do bạn chỉ nhập tên các tập tin Word vào cột A nên phải đặt các tập tin đó trong cùng thư mục với tập tin Excel, ngược lại thì code không biết tìm chúng ở đâu.

2. Không chỉ nhập tên mà còn phải nhập định dạng nữa. Tức không 651233 mà phải là vd. 651233.docx.

Code có thể tự thêm định dạng, vd. docx nhưng lúc đó tất cả các tập tin đều phải có định dạng docx, tức bạn không thêm được mật khẩu cho các tập tin vd. docm.

Vậy hãy nhập vào cột A tên cùng với định dạng.

Trong Excel -> mở tập tin DATA.xlsx -> lưu lại thành DATA.xlsm -> Alt + F11 -> menu Insert -> Module -> dán code sau vào Module -> lưu lại tập tin.

Khi cần thêm mật khẩu thì nhập dữ liệu vào cột A và B rồi chạy Sub SetPass

Sub SetPass()
Dim lastRow As Long, r As Long, filename As String, data(), fso As Object, wordApp As Object, doc As Object
'    xac dinh vung du lieu va nhap vao mang data
    With ThisWorkbook.Worksheets("Sheet1")
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lastRow = 1 Then Exit Sub
        data = .Range("A2:B" & lastRow).Value
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
'    khoi dong server WORD
    Set wordApp = CreateObject("Word.Application")
'    wordApp.Visible = True
'    duyet tung dong du lieu
    For r = 1 To UBound(data)
'        ten tap tin word
        filename = ThisWorkbook.Path & "" & data(r, 1)
        If fso.FileExists(filename) Then
'            tap tin word ton tai, mo tap tin trong WORD
            Set doc = wordApp.documents.Open(filename)
'            thiet lap mat khau
            doc.Password = data(r, 2)
'            dong tap tin
            doc.Close
        End If
    Next
    Set fso = Nothing
    wordApp.Quit
    Set wordApp = Nothing
End Sub

www.giaiphapexcel.com/diendan/threads/t%E1%BB%B1-%C4%91%E1%BB%99ng-%C4%91%E1%BA%B7t-pass-cho-nhi%E1%BB%81u-file-words-theo-list-excel.139999/

Khóa học SprinGO phù hợp

Thiết kế Tổng đãi ngộ (Total Rewards) theo khung SHRM

Khóa học “Thiết kế Tổng phần thưởng (Total Reward) chuẩn khung SHRM” giúp bạn nắm vững toàn bộ hệ thống đãi ngộ theo chuẩn...

Xem khóa học

★★★★★ 5 ★ 1 👤 2 ▥ 0

‹ Tự động đặt pass hoặc xóa cho nhiều... Save file word sang pdf nhanh ›

Quảng cáo

Bạn nên đọc

Email Word with Message (Uses xlDialogSendMail & Outlook Express)

2 Responses

hands says:

09/02/2023 at 11:26 am
Hic, em chạy trên office 2007, nhưng bị treo, mở lỗi thì bị chỗ này
```
'doc.Password = data(r, 2)
```
type miss match 13
Khi em bỏ cái này thì lại bị treo và lỗi ở đây
```
Set doc = wordApp.documents.Open(filename)
```
Xin hỏi là em chưa kích hoạt gì hay bị gì mọi người sửa giúp
Hôm nay em chạy cũng bị tình trạng giống bạn này.
Nhiều khi nó quay mãi không xong mặc dù em test có 2,3 file
Bạn mở 2, 3 cái tập tin mà bạn cho là "quay mãi không xong" -> với mỗi tập tin xóa các thông tin mật -> lưu lại. Bây giờ thử với 2, 3 tập tin mới. Nếu vẫn "quay mãi không xong" thì đính kèm lên đây. Tôi không có quả cầu thủy tinh, cũng không có tài nhìn trời mà đoán được như bạn. Và tôi sẽ chỉ thử trên Word, Excel 2010 vì tôi không có các phiên bản khác.
Bạn dùng phiên bản nào?
Em dùng 2010 anh ơi, em sẽ test lại lần nữa với file khác. Lỗi em sẽ quay màn hình up lên anh xem nhé!
File word em làm là file ko có gì, chỉ đổi tên thôi!

Em đã test lại và đúng là vẫn lỗi type mis 13 ở đoạn code
```
doc.Password = data(r, 2)
```
Còn khi em bỏ đoạn code này thì máy bị treo và báo liên tục là "Waiting for another application to complete an OLE action"
Khi dùng task manager tắt thì xuất hiện lỗi : Runtme error 4198, COMMAND FAILED
ở đoạn code này
```
Set doc = wordApp.documents.Open(filename)
```
Em đã dò từng code và thấy mình xót 1 code là
```
wordApp.Visible = True
```
Tuy nhiên, lại bị 1 vấn đề là các tập tin mở lên được nhưng bị read only, chứ không set pass.
Chết rồi. Khi tôi test thì trong cột B ở Excel tôi nhập những mật khẩu khác nhau nhưng là text, vd. "hic hic", chứ không là số, vd. 456789

Bạn thay thành
```
doc.Password = CStr(data(r, 2))
```
Cám ơn bác, em làm được rồi, nhưng cho em hỏi là dòng đó có ý nghĩa gì? Có phải chuyển đổi số thành text ko?
Bài này có thể mở rộng thêm 2 phần nữa được không bác:
1. Các file đã có pass rồi sẽ bỏ qua, và chỉ tạo pass cho file chưa có?
2. Các file (gồm có pass và chưa có pass) sẽ được xóa pass cũ và tạo lại pass mới!
Mong học hỏi mọi người!

Những cái gì tự làm được, đọc được thì đừng hỏi. Hãy click vào Cstr rồi nhấn F1 rồi đọc.

Tôi nghĩ thế này. Giả sử ta đang định mở a.docx. Nếu ta biết là a.docx đã có pass rồi và nhập vào cột C pass cũ thì sao? Thì dòng dữ liệu ấy bên Excel nhập vào làm gì khi mà trong trường hợp này sẽ chả có thiết lập pass mới? Nhưng giả sử đúng là a.docx đã có pass rồi nhưng ta không nhớ là nó có chưa, hoặc ta nhớ là có pass nhưng lại không nhớ pass. Lúc này do a.docx đã có pass nhưng code không nhập hộ bạn vì không biết pass là gì, vậy WORD hiển thị cửa sổ nhập pass. Bạn phải tự nhập pass nếu bỗng nhiên nhớ lại pass hoặc nhấn Cancel để đóng cửa sổ nhập pass.

Vài lưu ý:

1. Bạn phải dùng ô D2. Nếu D2 = rỗng thì có nghĩa là bạn đang muốn trường hợp 1, tức nếu có pass rồi thì thôi, chưa có pass thì mới thiết lập pass ở cột B. Nếu D2 = "x" thì bạn muốn trường hợp 2, tức luôn thiết lập pass ở cột B.
2. Bạn phải dùng cột C để nhập pass cũ. Nếu tập tin có pass cũ thì nhập vào cột C. Nếu tập tin chắc chắn không có pass cũ, hoặc bạn nhớ là có pass cũ nhưng quên pass, hoặc bạn không nhớ có pass cũ hay không thì cột C để trống.
Nếu tập tin chắc chắn có pass cũ nhưng bạn nhập vào cột C pass sai thì tập tin sẽ không được mở. Tập tin không được mở thì thánh cũng không thể thiết lập pass mới.
Nếu tập tin chắc chắn có pass cũ nhưng bạn để cột C trống thì Word sẽ hiển thị cửa sổ nhập pass (code không biết pass là gì để nhập thay bạn). Lúc đó nếu bạn bỗng nhớ ra pass hiện hành thì tự nhập, hoặc không nhớ nổi thì nhấn Cancel. Khi nhấn Cancel thì tập tin không được mở nên sẽ không thể thiết lập pass mới.

Tóm lại:
1. Để trống hoặc nhập x vào D2 để biết trường hợp 1 hay 2.
2. Trong cột B nhập pass mới, trong cột C để trống hoặc nhập pass cũ.
3. Nếu tập tin được mở thành công thì mới có chuyện thiết lập pass mới.
Muốn làm đúng ý thì trong trường hợp tập tin đã có pass thì bắt buộc phải nhớ pass và nhập vào cột C. Nếu không thì tập tin không mở được để làm tiếp việc thiết lập pass mới.

Bạn có đồng ý như thế? Nếu đồng ý mà thứ Bẩy, Chủ Nhật tôi có nhiều thời gian thì tôi sẽ nghiên cứu.

Ý tưởng của bác thấu đáo hơn em đấy.
Ý tưởng ban đầu của em là dự định quản lý file word từ excel, theo dạng [URL='giaiphapexcel.com/diendan/threads/t%E1%BB%95ng-quan-v%E1%BB%81-filesystemobject.95898/']FileSystemObject, rồi bảo mật bằng cách đặt pass đồng loạt, vì file word sẽ tăng số lượng theo thời gian nên mới có ý 1: Các file đã có pass rồi sẽ bỏ qua, và chỉ tạo pass cho file chưa có, để code không chạy lặp lại.
Còn ý thứ 2 là ý của em dự định với file quản lý pass như vậy, khi file nào em cần unpass cho người khác đọc thì em chạy 1 code, sau đó lại set pass mới.
Tuy nhiên, suy nghĩ kỹ lại thì đúng là sẽ gặp mấy trường hợp như anh nói, do đó ý tưởng để cột C của anh em thấy ok lắm (nhưng em cũng hơi thắc mắc là file pass này mình tạo ra mà, mình quản lý bằng excel, quên thì mở file excel ra coi, set pass cho file excel. Cũng có thể khi mở file excel ra, mình ngứa tay sửa pass,save lại mà không biết, do đó, file a.docx không mở được do đã sai pass. Cột c anh tạo vừa kiểm tra lại pass xem có khớp cột b khi mở file ra không cũng là ý rất hay, và em muốn thêm 1 ý nữa là anh làm thêm code unpass cho file mình muốn nữa được không?

Vấn đề là thế này. Những tập tin đã có pass thì bắt buộc bạn phải nhớ pass và bắt buộc phải nhập vào cột C (pass cũ). Bạn nói bạn quên pass? Thế thì bạn làm sao mở được tập tin để làm việc hàng ngày? Đã quên pass thì tập tin coi như là vứt đi.

Tập tin chưa có pass thì để trống cột C.
Nếu muốn thiết lập mật khẩu thì pass phải ghi vào cột B. Tức:
– pass cho tập tin chưa có mật khẩu: cột B = mật khẩu, cột C rỗng.
– pass mới cho tập tin đã có mật khẩu: cột B = pass mới, cột C = pass cũ.

D2 = rỗng -> trường hợp 1, D2 = x -> trường hợp 2.

Nếu tôi có nhiều thời gian thì thứ Bẩy, Chủ Nhật tôi sẽ xem.

và em muốn thêm 1 ý nữa là anh làm thêm code unpass cho file mình muốn nữa được không?

Thế những tập tin cần unpass thì tên của chúng và pass hiện hành của chúng bạn đặt tại đâu? Hay là cũng ở A, C? Nếu thế thì bạn muốn bằng cách nào để xác định là unpas và khi nào thì không unpass? Bằng cách viết riêng code cho unpass? Bằng cách gộp 2 code pass và unpass thành 1? Nếu thế thì lấy gì để nhận biết là phải unpass hay pass? Tôi giúp bạn code nhưng việc của bạn thì bạn phải nêu ý tưởng nào phù hợp nhất cho bạn.

Reply
hands says:

09/02/2023 at 11:30 am

Sau khi nghĩ lại tôi đề nghị bỏ phân biệt trường hợp 1 và 2.

Trường hợp bạn có pass mới nhưng cũng có cả pass cũ thì sẽ không thay đổi nếu đó là trường hợp 1. Và để biết đó là trường hợp 1 thì đánh dấu x ở cột D. Bây giờ thì đơn giản. Nếu tập tin có pass cũ mà bạn không muốn thay đổi sang mới vì bạn đeo cho nó huy hiệu "Trường hợp 1" thì thay vì nhập pass cũ và mới vào C và B, rồi đánh dấu x ở D thì đơn giản chỉ là không nhập gì cả. Vì có nhập pass cũ + mới + x thì code sau khi mở tập tin cũng chả làm gì với nó cả. Vậy nhập làm gì?

Tóm lại bạn chỉ nhập dữ liệu cho 3 trường hợp:
1. Muốn thiết lập pass cho tập tin chưa có pass: Nhập B, không nhập C
2. Muốn bỏ pass cho tập tin đã có pass: không nhập B, nhập C
3. Muốn đổi pass cũ sang pass mới: nhập B, nhập C

Trường hợp không nhập B và không nhập C nếu có (viết không suy nghĩ vì lúc đó đang mơ về buổi tối tuyệt vời) thì code cũng sẽ bỏ qua vì có mở tập tin thì cũng chả để làm gì. Chả phải thiết lập pass mà cũng chả phải bỏ pass.

Thử test code sau
```
Sub SetPass()
Const wdAlertsNone = 0
Const strPW As String = ""
Dim lastRow As Long, r As Long, k As Long, filename As String, newname As String, data(), fso As Object, wordApp As Object, doc As Object
'    xac dinh vung du lieu va nhap vao mang data
    With ThisWorkbook.Worksheets("Sheet1")
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        If lastRow = 1 Then Exit Sub
        data = .Range("A2:C" & lastRow).Value
        ReDim Preserve data(1 To UBound(data), 1 To 4)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
'    khoi dong server WORD
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True
'    duyet tung dong du lieu
    On Error Resume Next
    For r = 1 To UBound(data)
'        ten tap tin word
        filename = ThisWorkbook.Path & "" & data(r, 1)
        If fso.FileExists(filename) Then
'            tap tin word ton tai, mo tap tin trong WORD
'            bo qua truong hop khong co pass cu va moi, vi co mo cung cha de lam gi
            If data(r, 2) <> "" Or data(r, 3) <> "" Then
                Set doc = wordApp.documents.Open(filename, PasswordDocument:=CStr(data(r, 3)))
                If Err.Number Then
'                    co loi
                    data(r, 4) = "Kh" & ChrW(244) & "ng th" & ChrW(224) & "nh c" & ChrW(244) & "ng"
                    Err.Clear
                Else
'                    khong co loi
'                    thiet lap mat khau
                    doc.Password = CStr(data(r, 2))
'                    luu va dong tap tin
                    If data(r, 2) = "" Then
'                        bo pass cu
                        k = InStrRev(filename, ".")
                        newname = Left(filename, k - 1) & "_new" & Mid(filename, k)
                        doc.SaveAs2 newname, Password:=""
                        doc.Close
                        FileCopy newname, filename
                        Kill newname
                    Else
'                        thiet lap pass hoac thay pass cu bang pass moi
                        doc.Close
                    End If
                End If
            End If
        End If
    Next
    ThisWorkbook.Worksheets("Sheet1").Range("A2").Resize(UBound(data), UBound(data, 2)).Value = data
    Set fso = Nothing
    wordApp.Quit
    Set wordApp = Nothing

MsgBox "Done"
End Sub
```
Code xử lý lỗi. Lỗi sẽ có nếu tập tin thực sự có pass nhưng bạn không nhập pass vào cột C hoặc nhập sai pas. Riêng trường hợp lỗi khi bạn không nhập pass vào cột C thì bạn phải tự đóng cửa sổ nhập pass của WORD. Bằng cách nhấn Cancel hoặc bỗng nhiên nhớ ra pass và nhập vào sau đó nhấn OK.
Trường hợp có lỗi và không mở được tập tin thì code sẽ trả về ở cột D ở dòng tương ứng thông tin "Không thành công"

Reply