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 に答える