Tùy chọn
Protect nhiều file Words theo đường dẫn động
- Protect nhiều file Words theo đường dẫn động
-
RE: Protect nhiều file Words theo đường dẫn động
MTNQ > 30-11-15, 01:34 AM
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 -
RE: Protect nhiều file Words theo đường dẫn động
MTNQ > 30-11-15, 02:05 AM
À 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) -
RE: Protect nhiều file Words theo đường dẫn động
jeck09nt > 30-11-15, 09:37 AM
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, tranthanhan1962, hieuvn 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. -
RE: Protect nhiều file Words theo đường dẫn động
jeck09nt > 02-12-15, 12:46 PM
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 = Me. DocMgrPathPict
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 -
RE: Protect nhiều file Words theo đường dẫn động
MTNQ > 09-12-15, 07:41 AM
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 -
RE: Protect nhiều file Words theo đường dẫn động
MTNQ > 11-12-15, 05:44 PM
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é
-
RE: Protect nhiều file Words theo đường dẫn động
jeck09nt > 15-12-15, 12:58 PM
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 :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é !Mã PHP:MsgBox "File Word da duoc Protect, ban phai thuc hien Unprotect truoc khi thuc hien lai Protect !", vbCritical, "Thông báo"
Đường dẫn tại : http://www.mediafire.com/download/bdfm54...122015.zip -
RE: Protect nhiều file Words theo đường dẫn động
jeck09nt > 15-12-15, 01:00 PM
-
RE: Protect nhiều file Words theo đường dẫn động
MTNQ > 16-12-15, 01:29 AM
À, 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:
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)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 -
RE: Protect nhiều file Words theo đường dẫn động
MTNQ > 16-12-15, 01:52 AM
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