[엑셀vba] 보호된 시트를 해제해보자

우연히 시트가 보호된 엑셀 파일을 얻었다.

 

보호된 시트의 내용은 숨겨져있고, 그 속을 보고싶은 마음에 해제해보기로 했다.

 

시트보호해제 하는 방법은 구글링을 통해 알았고 

 

알아낸 방법을 자동화하기만 했다.

 

-----------------------------------------------------------------------------------------

* 매크로 동작 순서

 1. 시트보호된 엑셀파일을 선택한다. 

 2. 엑셀파일 복사

 3. 복사된 엑셀파일 확장자를 .zip 으로 변경

 4. 압축을 푼다

 5. 워크시트가 저장된 폴더의 파일은 텍스트파일로 변경해준다.

(압축해제 했을 때 워크시트는 sheet1.xml, sheet2.xml 이런식으로 저장되있다.)

 6. 텍스트파일을 엑셀시트에 불러와서 시트보호와 관련된 문구를 지우고 새로운 텍스트 파일을 만든다.

 7. 새로운 텍스트 파일을 .xml 확장자로 변경해준다.

 8. 모든 시트를 작업한다.

 9. 압축한다.

 10. 압축파일을 .xlsx 파일로 확장자 변경 

 11. 열어본다. 시트보호해제 된 것을 확인한다

 

※ 원본파일은 그대로두고 새로운 파일로 만들어짐. 파일명에 '(시트보호해제)'가 붙음

※ 불필요한 파일은 중간중간 다 삭제처리함

※ .xlsx, .xlsm 가능

※ .xls 파일의 경우 .xlsx 확장자로 저장해서 매크로 실행하면 가능

-----------------------------------------------------------------------------------------

 

매크로 실행 영상

시트보호해제하기.xlsm

0.04MB

-----------------------------------------------------------------------------------------

매크로 모듈 구성

 

1. 시트보호해제() - 메인함수

2. Unzip(file_name) - 압축해제

3. 폴더압축하기(zip_path) - 압축하기

4. NewZip(sPath) - 압축하기

5. TextStreamRead(strPathName) - UTF-8로 읽어오기

6. TextStreamWrite(strPathName, strString) - UTF-8로 저장하기

 

-----------------------------------------------------------------------------------------

구글링으로 알아낸 압축풀기 코드 (주석이 몇몇은 영어인데.. 가방끈이 짧아 뭔소린지 잘모름)

 

Sub Unzip(file_Name As String) '압축해제 모듈, file_Name은 파일 경로
    Dim FSO As Object
    Dim oApp As Object
    Dim FName As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String

    FName = file_Name
    If FName = False Then 'Do nothing

    Else
        DefPath = Mid(file_Name, 1, InStrRev(file_Name, "\")) 
        If Right(DefPath, 1) <> "\" Then '문자열 가장 오른쪽에 \ 없으면 붙여주기
            DefPath = DefPath & "\"
        End If

        '압축해제 할 폴더경로 넣기
        FileNameFolder = DefPath & "Unzip\"

        '압축해제 할 폴더 생성

        MkDir FileNameFolder

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

 

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(FName).items

        'If you want to extract only one file you can use this:
        'oApp.Namespace(FileNameFolder).CopyHere _

        'oApp.Namespace(Fname).items.Item("test.txt")

        'MsgBox "You find the files here: " & FileNameFolder

 

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")

        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

 

 

-----------------------------------------------------------------------------------------

구글링으로 알아낸 압축하는 코드

압축할땐 모듈 2개로 구성되있음

 

압축하기 모듈 1

Sub 폴더압축하기(ByVal Zip_Path As String)
    Dim FileNameZip, FolderName
    Dim file_Name, DefPath As String
    Dim oApp As Object

    DefPath = Mid(Zip_Path, 1, InStrRev(Zip_Path, "\")) '압축파일 저장될 경로
    file_Name = Mid(Zip_Path, InStrRev(Zip_Path, "\") + 1, InStrRev(Zip_Path, ".") - InStrRev(Zip_Path, "\") - 1)
    FolderName = DefPath & "unzip"    '압축할 폴더 경로

    FileNameZip = DefPath & file_Name & "(시트보호해제)" & ".zip"

    '빈 압축파일 생성
    NewZip (FileNameZip)

    Set oApp = CreateObject("Shell.Application")
    'Copy the files to the compressed folder
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items

    '압축이 완료될때까지 기다림
    On Error Resume Next
    Do Until oApp.Namespace(FileNameZip).items.Count = _
       oApp.Namespace(FolderName).items.Count
        Application.Wait (Now + TimeValue("0:00:01"))
    Loop
    On Error GoTo 0
End Sub

 

 

압축하기 모듈 2

Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function

 

 

-----------------------------------------------------------------------------------------

사용자 정의 함수: UTF-8로 텍스트 파일 읽어오기

 

Function TextStreamRead(strPathName As String)

    Dim objStream As Object
   
    Set objStream = CreateObject("ADODB.Stream")

    With objStream
   
        .Open
        .Type = 2
        .Charset = "UTF-8"
        .LoadFromFile strPathName
        TextStreamRead = .ReadText '리턴값: 텍스트파일의 모든 문자
       
    End With
   
    Set objStream = Nothing

End Function

-----------------------------------------------------------------------------------------

사용자 정의 함수: UTF-8로 텍스트 파일 쓰기

 

Function TextStreamWrite(strPathName As String, strString As String)

'strPathName:저장될 파일경로, strString:저장할 내용

    Dim objStream As Object
   
    Set objStream = CreateObject("ADODB.Stream")
   
    With objStream
   
        .Open
        .Type = 2
        .Charset = "UTF-8"
        .WriteText strString '저장할 내용
        .SaveToFile strPathName, 2 
       
    End With
   
    Set objStream = Nothing
 
End Function

-----------------------------------------------------------------------------------------