Đánh giá chủ đề:
  • 0 Votes - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
[Help] Protect nhiều file Words theo đường dẫn động
#21
Hàm của MTNQ viết cũng gần giống như của bác hieuvn nhưng có hơi khác chút.
Thường thì khi viết lệnh mở một file Word hay Excel, để tránh lỗi, ta kiểm tra xem nó đã được mở hay chưa. 
Nếu đã mở thì sử dụng luôn, và mở file nào thì đóng file đó, không mở thì không đóng, chỉ thay đổi rồi lưu lại:

Mã:
Function ProtectDoc(ByVal strDocPath As String, strPwd As String, blnProtect As Boolean) As Boolean
    Dim wrdApp As Object
    Dim wrdDoc As Object
    Dim strFolderPath As String
    Dim strFileName As String
    Dim strFileType As String
    Dim blnQuitApp As Boolean
    Dim blnCloseDoc As Boolean
    
    On Error Resume Next
    If strDocPath = Trim(strDocPath) = "" Then Exit Function
    strFolderPath = Left$(strDocPath, InStrRev(strDocPath, "\"))
    strFileName = Mid$(strDocPath, Len(strFolderPath) + 1)
    strFileType = Mid$(strFileName, InStrRev(strFileName, ".") + 1)
    
    If strFolderPath = "" Or strFileName = "" Or strFileType = "" Then
        MsgBox "Duong dan """ & strDocPath & """ khong dung", , "Loi"
        Exit Function
    End If
    If strFileType <> "doc" And strFileType <> "docx" Then Exit Function
    
    Set wrdApp = GetObject(, "Word.Application")
    If wrdApp Is Nothing Then
        Err.Clear
        Set wrdApp = CreateObject("Word.Application"): blnQuitApp = True
        Set wrdDoc = wrdApp.Documents.Open(strDocPath): blnCloseDoc = True
    Else
        Set wrdDoc = wrdApp.Documents(strFileName)
        If Err.Number <> 0 Then
            Err.Clear
            Set wrdDoc = wrdApp.Documents.Open(strDocPath): blnCloseDoc = True
        End If
    End If
    If Err.Number <> 0 Then GoTo ErrorHandler
    
    On Error GoTo ErrorHandler
    If blnProtect Then
        If wrdDoc.ProtectionType = -1 Then wrdDoc.Protect 2, , strPwd: wrdDoc.Save
    Else
        If wrdDoc.ProtectionType <> -1 Then wrdDoc.Unprotect strPwd: wrdDoc.Save
    End If
    
    If (Not wrdDoc Is Nothing) And blnCloseDoc Then wrdDoc.Close True
    ProtectDoc = True

Exit_ErrorHandler:
    If Not wrdDoc Is Nothing Then Set wrdDoc = Nothing
    If Not wrdApp Is Nothing Then
        If blnQuitApp Then wrdApp.Quit
        Set wrdApp = Nothing
    End If
    Exit Function
    
ErrorHandler:
    ProtectDoc = False
    Select Case Err.Number
        Case 5174
            MsgBox "Khong tim thay file: " & vbCrLf & strDocPath, , "Loi"
        Case 5485
            If blnCloseDoc Then wrdDoc.Close False
            MsgBox "Mat khau: """ & strPwd & """ khong dung" & vbCrLf & strDocPath, , "Loi"
        Case Else
            MsgBox "File: """ & strDocPath & """" & vbCrLf & Err.Description, _
                vbExclamation, "Error ProtectDoc: " & Err.Number
    End Select
    Err.Clear
    GoTo Exit_ErrorHandler
End Function

Demo ProtectWords.mdb
Chữ ký của MatTroiNguQuen Thời gian nước chảy... da mòn
Ngủ quên một chốc thấy còn bộ xương!
Reply
Những người đã cảm ơn jeck09nt
#22
À quên:
-Cái MsgBoxTV trong Demo là của bác Ân
-MTNQ sửa module: bimAPIs của bạn lại và thêm hàm GetOpenMultiFiles. 
Hàm này về cơ bản cũng giống hàm GetOpenFile trong module nhưng có thêm các tham số để có thể tùy chọn bộ lọc và chọn được nhiều files
(Bạn tham khảo thêm ở link sau: http://thuthuataccess.com/forum/thread-8088.html)
Chữ ký của MatTroiNguQuen Thời gian nước chảy... da mòn
Ngủ quên một chốc thấy còn bộ xương!
Reply
Những người đã cảm ơn jeck09nt
#23
Thật cám ơn MatTroiNguQuen rất nhiều vì đã thực hiện bản Demo theo ý tưởng ban đầu của mình; một lần nữa cũng xin cám ơn Maidinhdan, tranthanhan1962hieuvn và tất cả các Anh/Chị đã quan tâm đến chủ đề nay !
Chúc anh/chị sức khỏe và thành công !!!
Trân trọng.
Chữ ký của jeck09nt Hãy chia sẻ kinh nghiệm cùng mình trên ThuThuatAccess nhé! Chúc vui vẻ rose
Reply
Những người đã cảm ơn
#24
Gửi MatTroiNguQuen,
Căn cứ theo bản Demo, mình có thiết kế thêm một số trường để khi Protect có thể tự động insert : "ngày tháng hiện hành và User đăng nhập máy tính "  vào Header (canh phải); đồng thời insert "số trang" (canh giữa) và "Logo" (canh phải) vào Footer. 
Ví dụ : file word "Mau insert Header - Footer.doc" trong folder đính kèm.
Mình có sưu tầm đoạn code sau để thực hiện điều này nhưng không biết để ở đoạn nào ?
Mã PHP:
Pathpict MeDocMgrPathPict
     Const wdAlignPageNumberCenter 
1            
      docfile
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text ""
        docfile.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text ""
        docfile.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text Now() & " - " Me.txtUserName
       docfile
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Font.Name "Times New Roman"
       docfile.Sections(1).Headers(wdHeaderFooterPrimary).Range.Font.Size "11"
       docfile.Sections(1).Headers(wdHeaderFooterPrimary).Range.Font.Color wdColorRed
       docfile
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Paragraphs(1).Alignment wdAlignParagraphRight    
      docfile
.Sections.Item(1).Footers(wdHeaderFooterPrimary).Range.InlineShapes.AddPicture (Pathpict)
       docfile.Sections(1).Footers(wdHeaderFooterPrimary).Range.Paragraphs(1).Alignment wdAlignParagraphRight
       If ChkChensotrang 
True Then
       docfile
.Sections(1).Footers(wdHeaderFooterPrimary).Range.Font.Bold True
       docfile
.Sections(1).Footers(wdHeaderFooterPrimary).Range.Font.Size "11"
       docfile.Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberCenter)
       End If 


MatTroiNguQuen vui lòng xem file mình đính kèm nhé và hướng dẫn giúp.
Xin cám ơn !
http://www.mediafire.com/download/9px0zf...ds_Fix.zip
Chữ ký của jeck09nt Hãy chia sẻ kinh nghiệm cùng mình trên ThuThuatAccess nhé! Chúc vui vẻ rose
Reply
Những người đã cảm ơn
#25
Bác xem Demo, có gì không hiểu thì hỏi nhé:

Demo ProtectWords 09122015.rar

Mã:
Option Compare Database
Option Explicit

Private Const wdAllowOnlyFormFields = 2
Private Const wdHeaderFooterPrimary = 1
Private Const wdAlignParagraphLeft = 0
Private Const wdAlignPageNumberCenter = 1
Private Const wdAlignParagraphRight = 2
Private Const wdColorRed = 255

Mã:
Function ProtectDoc(ByVal strDocPath As String, strPwd As String, blnProtect As Boolean, varText As Variant) As Boolean
    Dim wrdApp As Object
   Dim wrdDoc As Object
   Dim strFolderPath As String
   Dim strFileName As String
   Dim strFileType As String
   Dim blnQuitApp As Boolean
   Dim blnCloseDoc As Boolean
   
   On Error Resume Next
   If strDocPath = Trim(strDocPath) = "" Then Exit Function
   strFolderPath = Left$(strDocPath, InStrRev(strDocPath, "\"))
   strFileName = Mid$(strDocPath, Len(strFolderPath) + 1)
   strFileType = Mid$(strFileName, InStrRev(strFileName, ".") + 1)
   
   If strFolderPath = "" Or strFileName = "" Or strFileType = "" Then
       MsgBox "Duong dan """ & strDocPath & """ khong dung", , "Loi"
       Exit Function
   End If
   If strFileType <> "doc" And strFileType <> "docx" Then Exit Function
   
   Set wrdApp = GetObject(, "Word.Application")
   If wrdApp Is Nothing Then
       Err.Clear
       Set wrdApp = CreateObject("Word.Application"): blnQuitApp = True
       Set wrdDoc = wrdApp.Documents.Open(strDocPath): blnCloseDoc = True
   Else
       Set wrdDoc = wrdApp.Documents(strFileName)
       If Err.Number <> 0 Then
           Err.Clear
           Set wrdDoc = wrdApp.Documents.Open(strDocPath): blnCloseDoc = True
       End If
   End If
   If Err.Number <> 0 Then GoTo ErrorHandler
   
   On Error GoTo ErrorHandler
   If blnProtect Then
       If wrdDoc.ProtectionType = -1 Then
           InsertText wrdDoc, varText
           wrdDoc.Protect 2, , strPwd: wrdDoc.Save
       Else
           wrdDoc.Unprotect strPwd
           InsertText wrdDoc, varText
           wrdDoc.Protect 2, , strPwd: wrdDoc.Save
       End If
   Else
       If wrdDoc.ProtectionType <> -1 Then wrdDoc.Unprotect strPwd: wrdDoc.Save
   End If
   
   If (Not wrdDoc Is Nothing) And blnCloseDoc Then wrdDoc.Close True
   ProtectDoc = True

Exit_ErrorHandler:
   If Not wrdDoc Is Nothing Then Set wrdDoc = Nothing
   If Not wrdApp Is Nothing Then
       If blnQuitApp Then wrdApp.Quit
       Set wrdApp = Nothing
   End If
   Exit Function
   
ErrorHandler:
   ProtectDoc = False
   Select Case Err.Number
       Case 5174
           MsgBox "Khong tim thay file: " & vbCrLf & strDocPath, , "Error ProtectDoc: " & Err.Number
       Case 5485
           If blnCloseDoc Then wrdDoc.Close False
           MsgBox "Mat khau: """ & strPwd & """ khong dung" & vbCrLf & strDocPath, , "Loi"
       Case Else
           MsgBox "(File: " & strDocPath & ")" & vbCrLf & "Description: " _
               & Err.Description, vbExclamation, "Error ProtectDoc: " & Err.Number
   End Select
   On Error GoTo 0
   GoTo Exit_ErrorHandler
End Function


Mã:
Function InsertText(docfile As Object, varText As Variant)
   On Error GoTo ErrorHandler
   Dim strDate As String
   Dim strCurUser As String
   Dim blnChensotrang As Boolean
   Dim strPathpict As String
   
   strDate = varText(0)
   strCurUser = varText(1)
   blnChensotrang = varText(2)
   strPathpict = varText(3)
   With docfile
       .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = ""
       .Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = ""
       
       With .Sections(1).Headers(wdHeaderFooterPrimary).Range
           If strDate & strCurUser <> "" Then
               .Text = strDate & " - " & strCurUser
               .Font.Name = "Times New Roman"
               .Font.Size = "11"
               .Font.Color = wdColorRed
               .Paragraphs(1).Alignment = wdAlignParagraphRight
           End If
       End With
       
       If strPathpict <> "" Then
           .Sections.Item(1).Footers(wdHeaderFooterPrimary).Range.InlineShapes.AddPicture (strPathpict)
           .Sections(1).Footers(wdHeaderFooterPrimary).Range.Paragraphs(1).Alignment = wdAlignParagraphRight
       End If
       
       If blnChensotrang = True Then
           .Sections(1).Footers(wdHeaderFooterPrimary).Range.Font.Bold = True
           .Sections(1).Footers(wdHeaderFooterPrimary).Range.Font.Size = "11"
           .Sections(1).Footers(1).PageNumbers.Add (wdAlignPageNumberCenter)
       End If
       
   End With
   
   
Exit_ErrorHandler:
   Exit Function
   
ErrorHandler:
   Select Case Err.Number
       Case 5152
           MsgBox "Khong tim thay file: " & vbCrLf & strPathpict, , "Error InsertText: " & Err.Number
           Resume Next
       Case Else
           MsgBox Err.Description, vbExclamation, "Error InsertText: " & Err.Number
   End Select
   Resume Exit_ErrorHandler
End Function
Chữ ký của MatTroiNguQuen Thời gian nước chảy... da mòn
Ngủ quên một chốc thấy còn bộ xương!
Reply
Những người đã cảm ơn maidinhdan , jeck09nt , Noname
#26
Sorry, hàm ProtectDoc ở trên còn có chỗ chưa ổn:

Function ProtectDoc(ByVal strDocPath As String, strPwd As String, blnProtect As Boolean, varText As Variant) As Boolean
...
  If blnProtect Then
      If wrdDoc.ProtectionType = -1 Then
...
      Else
         ' Trường hợp file đã bị khóa 
         wrdDoc.Unprotect strPwd
          InsertText wrdDoc, varText
          wrdDoc.Protect 2, , strPwd: wrdDoc.Save
      End If
  Else
     ...
  End If
 ...
End Function

Nên thay đoạn tô màu đỏ bằng một câu thông báo file word đã được Protect và yêu cầu phải mở khóa (hoặc đưa ra InputBox để người dùng nhập mật khẩu mở khóa ) trước khi chèn ngày giờ, logo,... Vì mật khẩu khóa file lúc trước có thể không trùng khớp với mật khẩu hiện tại

PS: Các file Demo thường chưa hoàn chỉnh, bác test lại, có lỗi hay có gì chưa hiểu thì cứ hỏi nhé  015
Chữ ký của MatTroiNguQuen Thời gian nước chảy... da mòn
Ngủ quên một chốc thấy còn bộ xương!
Reply
Những người đã cảm ơn Noname
#27
Xin cám ơn MatTroiNguQuen đã phản hồi sớm !!!
Trên cơ sở Demo, mình đã điều chỉnh lại : 
   1. Cảnh báo lỗi khi không nhập mật khẩu và chọn đường dẫn Logo
   2.Tạo thêm Textbox để có thể tùy chọn Logo
   3.Mình đã tạo thêm code thông báo khi file word đã Protect nếu tiếp tục thưc hiện nữa : 
Mã PHP:
MsgBox "File Word da duoc          Protect, ban phai thuc hien Unprotect truoc khi thuc hien lai Protect !"vbCritical"Thông báo" 
Tuy nhiên, thực hiện lệnh này khi chọn "Tất cả files  có trong form" hay "Các tập tin trong thư mục" thì mình phải ấn chuột nhiều lần => Mình nhờ MatTroiNguQuen xem giúp nhé !


 Đường dẫn tại : http://www.mediafire.com/download/bdfm54...122015.zip
Chữ ký của jeck09nt Hãy chia sẻ kinh nghiệm cùng mình trên ThuThuatAccess nhé! Chúc vui vẻ rose
Reply
Những người đã cảm ơn
#28
Demo ProtectWords15122015

Mình gửi lại đường dẫn !
Chữ ký của jeck09nt Hãy chia sẻ kinh nghiệm cùng mình trên ThuThuatAccess nhé! Chúc vui vẻ rose
Reply
Những người đã cảm ơn
#29
À, sau câu thông báo thì ta phải cho ProtectDoc = False, đóng file word lại và thoát ra:

Mã:
If wrdDoc.ProtectionType = -1 Then
           InsertText wrdDoc, varText
           wrdDoc.Protect 2, , strPwd: wrdDoc.Save
       Else
           MsgBox "File Word da duoc Protect, ban phai thuc hien Unprotect truoc khi thuc hien lai Protect !", vbCritical, "Thông báo"
           ProtectDoc = False
           If blnCloseDoc Then wrdDoc.Close False
           GoTo Exit_ErrorHandler
       End If

-Hàm UnInsertText có thể viết gọn lại như sau:
Mã:
Function UnInsertText(docfile As Object)
   On Error GoTo ErrorHandler
       
   With docfile
       .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = ""
       .Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = ""
                     
   End With
       
Exit_ErrorHandler:
   Exit Function
   
ErrorHandler:
   MsgBox Err.Description, vbExclamation, "Error UnInsertText: " & Err.Number
   Resume Exit_ErrorHandler
End Function
Vì tham số varText không cần nữa. Khi đó cú pháp  gọi hàm là : UnInsertText wrdDoc  hoặc Call UnInsertText(wrdDoc)
Chữ ký của MatTroiNguQuen Thời gian nước chảy... da mòn
Ngủ quên một chốc thấy còn bộ xương!
Reply
Những người đã cảm ơn
#30
Nếu bác muốn đưa ra InputBox thì ta phải khai báo thêm một biến khác với biến strPwd (ví dụ strOldPwd chẳng hạn). Khi đó đoạn code của bác phải sửa lại như sau:

Mã:
Dim intResponse As Integer
   intResponse = MsgBox("File Word: " & strFileName & vbCrLf & " Da duoc Protect, neu thuc hien tiep chon YES, khong chon NO !", vbYesNo, "Thông báo")
   If intResponse = vbYes Then
       Dim strOldPwd As String
       strOldPwd = InputBox("Hay nhap mat khau cu da protect", "Thong bao !")
       If strOldPwd > "" Then
           wrdDoc.Unprotect strOldPwd
           InsertText wrdDoc, varText
           wrdDoc.Protect 2, , strPwd: wrdDoc.Save
       Else
           ProtectDoc = False
           If blnCloseDoc Then wrdDoc.Close False
           GoTo Exit_ErrorHandler
       End If
   Else
       ProtectDoc = False
       If blnCloseDoc Then wrdDoc.Close False
       GoTo Exit_ErrorHandler
   End If
Chữ ký của MatTroiNguQuen Thời gian nước chảy... da mòn
Ngủ quên một chốc thấy còn bộ xương!
Reply
Những người đã cảm ơn jeck09nt


Có thể liên quan đến chủ đề
Chủ đề: Tác giả Trả lời: Xem: Bài mới nhất
  Ms Access VBA và Google drive, một vài ý tưởng trong chia sẻ và đồng bộ số liệu... paulsteigel 46 3,857 07-10-16, 02:43 PM
Bài mới nhất: kieu manh
  Ứng dụng đổi tên file trong windows hàng loạt tranthanhan1962 7 1,212 19-09-16, 04:16 PM
Bài mới nhất: maidinhdan
  Xuất từ Access ra excel mà không cần phải có file định sẵn trungminh 3 354 18-09-16, 02:33 AM
Bài mới nhất: maidinhdan
  Export dữ liệu sang Word ( Nhiều dòng trong sub) danhxetnghiem 26 3,090 01-08-16, 11:08 AM
Bài mới nhất: jeck09nt
  Export Table từ access sang 1 file word có sẵn! cong_agribankPT 50 14,984 02-05-16, 10:52 PM
Bài mới nhất: kuzinhy

Chuyển nhanh:


User(s) browsing this thread: 1 Guest(s)
Diễn Đàn Thơ Văn Thi Ẩm Lâu|Nhà Hàng Sông Thơ