1

我通过复制将 Sheet2 保存到新工作簿中，但这样做会取消保护新工作簿中 Sheet2 中存在的 VBA 代码。原始工作簿具有受保护的 VB 项目。

有关如何使用 VB 项目设置仅保存 Sheet2 的任何建议？

解锁VBA的代码：

Sub UnlockVBA(NewWbPath As String)
    Dim oWb As Object, xlAp As Object

    Set xlAp = CreateObject("Excel.Application")

    xlAp.Visible = True

    '~~> Open the workbook in a separate instance
    Set oWb = xlAp.Workbooks.Open(NewWbPath)

    '~~> Launch the VBA Project Password window
    '~~> I am assuming that it is protected. If not then
    '~~> put a check here.
    xlAp.VBE.CommandBars(1).FindControl(ID:=2578, recursive:=True).Execute

    '~~> Your passwword to open then VBA Project
    MyPassword = "pa$$w0rd"

    '~~> Get the handle of the "VBAProject Password" Window
    Ret = FindWindow(vbNullString, "VBAProject Password")

    If Ret <> 0 Then
        'MsgBox "VBAProject Password Window Found"

        '~~> Get the handle of the TextBox Window where we need to type the password
        ChildRet = FindWindowEx(Ret, ByVal 0&, "Edit", vbNullString)

        If ChildRet <> 0 Then
            'MsgBox "TextBox's Window Found"
            '~~> This is where we send the password to the Text Window
            SendMess MyPassword, ChildRet

            DoEvents

            '~~> Get the handle of the Button's "Window"
            ChildRet = FindWindowEx(Ret, ByVal 0&, "Button", vbNullString)

            '~~> Check if we found it or not
            If ChildRet <> 0 Then
                'MsgBox "Button's Window Found"

                '~~> Get the caption of the child window
                strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                GetWindowText ChildRet, strBuff, Len(strBuff)
                ButCap = strBuff

                '~~> Loop through all child windows
                Do While ChildRet <> 0
                    '~~> Check if the caption has the word "OK"
                    If InStr(1, ButCap, "OK") Then
                        '~~> If this is the button we are looking for then exit
                        OpenRet = ChildRet
                        Exit Do
                    End If

                    '~~> Get the handle of the next child window
                    ChildRet = FindWindowEx(Ret, ChildRet, "Button", vbNullString)
                    '~~> Get the caption of the child window
                    strBuff = String(GetWindowTextLength(ChildRet) + 1, Chr$(0))
                    GetWindowText ChildRet, strBuff, Len(strBuff)
                    ButCap = strBuff
                Loop

                '~~> Check if we found it or not
                If OpenRet <> 0 Then
                    '~~> Click the OK Button
                    SendMessage ChildRet, BM_CLICK, 0, vbNullString
                Else
                    MsgBox "The Handle of OK Button was not found"
                End If
            Else
                 MsgBox "Button's Window Not Found"
            End If
        Else
            MsgBox "The Edit Box was not found"
        End If
    Else
        MsgBox "VBAProject Password Window was not Found"
    End If
End Sub
4

1 回答 1

1

工作表或模块的 VBA 代码永远不会单独受到保护，但整个 VBA 项目都会受到保护。

实现您想要的简单方法是使用Workbook.SaveCopyAs然后打开该副本并删除不需要的工作表。

请参阅有关Workbook.SaveCopyAs 方法的 MSDN 文章

如果该链接失效，请发布该页面的屏幕截图。

在此处输入图像描述

编辑

这将做你想要的。但是，这也将复制到任何模块。您将不得不单独删除它们。为此，您可能会看到Deleting A Module From A Project 这里

久经考验

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

Sub Sample()
    Dim NewWb As Workbook
    Dim ws As Worksheet
    Dim shName As String, NewWBName As String

    '~~> Name of the new workbook
    NewWBName = "Output.xlsm"
    '~~> Name of the sheet you want to copy across
    shName = "Sheet1"

    '~~> Create a copy in the users temp directory
    ThisWorkbook.SaveCopyAs TempPath & NewWBName

    '~~> Open the workbook
    Set NewWb = Workbooks.Open(TempPath & NewWBName)

    '~~> Delete unwanted sheets
    For Each ws In NewWb.Worksheets
        If ws.Name <> shName Then
            Application.DisplayAlerts = False
            ws.Delete
            Application.DisplayAlerts = True
        End If
    Next

    '~~> Save the new file at desired location
    NewWb.SaveAs "C:\Output.xlsm", 52

    '~~> Delete temp file
    Kill TempPath & NewWBName
End Sub

Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function
于 2013-11-06T19:18:58.270 回答