Save Copy File as Read Only (VBA)

[ybr_15]

Hi dear,

I am still learning about vba. I have a code to create copy/duplicate file to other directory, like this:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim FSO As Object
    Dim strTargetPath As String
    Dim strFileName As String
    Dim strFilestrFileExtensionension As String
    Dim strFolderName As String
    
    Application.EnableEvents = False
    strTargetPath = "\\192.168.0.6\Production"
    strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
    strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
    strFolderName = strFileName

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(strTargetPath) Then
        If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
            FSO.CreateFolder (strTargetPath & "/" & strFolderName)
        End If
        wb.SaveCopyAs strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension
    Else
        MsgBox "ERROR:  Source File does not exist or is not accessible."
    End If
    Application.EnableEvents = True
End Sub

But, now I want to add or change the code so that the file copy on the server (\\ 192.168.0.6 \ Production) becomes a read only file so it can be opened but it cannot be modified by others. Can you help me? Thank you (Note: Sorry for my bad English)

 

[jmacleary]

Hello.

Add the line shown in red:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim FSO As Object
    Dim strTargetPath As String
    Dim strFileName As String
    Dim strFilestrFileExtensionension As String
    Dim strFolderName As String
    
    Application.EnableEvents = False
    strTargetPath = "\\192.168.0.6\Production"
    strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
    strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
    strFolderName = strFileName

    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(strTargetPath) Then
        If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
            FSO.CreateFolder (strTargetPath & "/" & strFolderName)
        End If
        wb.SaveCopyAs strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension
[COLOR=#ff0000]        SetAttr strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension, vbReadOnly[/COLOR]
    Else
        MsgBox "ERROR:  Source File does not exist or is not accessible."
    End If
    Application.EnableEvents = True
End Sub

 

[ybr_15]

Hi jmacleary,

Many thanks, your code works properly

 

[ybr_15]

Hi jmacleary,

Sorry, I tried your code but I got error (Run-time error '1004' : Microsoft Excel cannot acess file...) in this line every time I click SAVE:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim FSO As Object
Dim strTargetPath As String
Dim strFileName As String
Dim strFilestrFileExtensionension As String
Dim strFolderName As String

Application.EnableEvents = False
strTargetPath = "\\192.168.0.6\Production"
strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
strFolderName = strFileName

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(strTargetPath) Then
If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
FSO.CreateFolder (strTargetPath & "/" & strFolderName)
End If
[COLOR=#ffa500]wb.SaveCopyAs strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension[/COLOR]
SetAttr strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension, vbReadOnly
Else
MsgBox "ERROR: Source File does not exist or is not accessible."
End If
Application.EnableEvents = True
End Sub

 

[jmacleary]

Ah yes. As written, it will only work the first time the file is saved. Try this modified version:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim FSO As Object
Dim strTargetPath As String
Dim strFileName As String
Dim strFilestrFileExtensionension As String
Dim strFolderName As String
[COLOR=#ff0000]Dim strFullPath As String[/COLOR]

Application.EnableEvents = False
strTargetPath = "\\192.168.0.6\Production"
strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
strFolderName = strFileName

Set FSO = CreateObject("Scripting.FileSystemObject")

If FSO.FolderExists(strTargetPath) Then
If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
FSO.CreateFolder (strTargetPath & "/" & strFolderName)
End If
[COLOR=#ff0000]strFullPath= strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension
If Dir(strFullPath) > "" Then   ' look to see if file exists
     SetAttr strFullPath, vbNormal
End If
wb.SaveCopyAs strFullPath
SetAttr strFullPath, vbReadOnly[/COLOR]
Else
MsgBox "ERROR: Source File does not exist or is not accessible."
End If
Application.EnableEvents = True
End Sub

 

[ybr_15]

Hi again jmacleary,

I got error in this line (Run-time error '52': Bad file name or number)

If Dir(strFullPath) = "" Then

Thanks

 

[jmacleary]

Somehow the line setting the full path has been modified. Replace it with this:

strFullPath = strTargetPath & "" & strFolderName & "" & strFileName & "." & strFileExtension

 

[ybr_15]

Hi jmacleary,

I tried to modified your code and work properly, here the code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim FSO As Object
    Dim strTargetPath As String
    Dim strFileName As String
    Dim strFilestrFileExtensionension As String
    Dim strFolderName As String
    Dim strFullPath As String
   
    Application.EnableEvents = False
    strTargetPath = "\\192.168.0.6\Production"
    strFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".") - 1))
    strFileExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))
    strFolderName = strFileName


    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    If FSO.FolderExists(strTargetPath) Then
        If Not FSO.FolderExists(strTargetPath & "/" & strFolderName) Then
            FSO.CreateFolder (strTargetPath & "/" & strFolderName)
        End If
        strFullPath = strTargetPath & "\" & strFolderName & "\" & strFileName & "." & strFileExtension
        If FSO.FileExists(strFullPath) Then
            SetAttr strFullPath, vbNormal
        End If
        wb.SaveCopyAs strFullPath
        SetAttr strFullPath, vbReadOnly
    Else
        MsgBox "ERROR:  Target Folder does not exist or is not accessible."
    End If
    Application.EnableEvents = True



End Sub

Thank you

 

[Giannihun]

Hi,

This code works perfectly for me, thanks for that.
Could you help me how to use this for saving the copy as macro disabled file? .xlsx