FAQ 工作薄及工作表 (Update 8 Aug 2005)

Emily

列出所有工作薄的 VBA

由 Mr Colo写的 VBA 需要在VBA内选取 Microfost Visual Basic Applications Extensbility

请在 Tools - 宏 - 安全性 - 选取 信任存取 Visual Basic 项目

' Module
' List All VBA module
Dim x As Long
Dim aList()

Sub GetVbProj()
    Dim oVBC As VBIDE.VBComponent
    Dim Wb As Workbook
    x = 2
    For Each Wb In Workbooks
        For Each oVBC In Workbooks(Wb.Name).VBProject.VBComponents
            If Workbooks(Wb.Name).VBProject.Protection = vbext_pp_none Then
                Call GetCodeRoutines(Wb.Name, oVBC.Name)
            End If
        Next
    Next
    With Sheets.Add
        .[A1].Resize(, 3).Value = Array("Workbook", "Module", "Procedure")
        .[A2].Resize(UBound(aList, 2), UBound(aList, 1)).Value = _
        Application.Transpose(aList)
        .Columns("A:C").Columns.AutoFit
    End With
End Sub

Private Sub GetCodeRoutines(wbk As String, VBComp As String)
    Dim VBCodeMod As CodeModule
    Dim StartLine As Long

    On Error Resume Next
    Set VBCodeMod = Workbooks(wbk).VBProject.VBComponents(VBComp).CodeModule
    With VBCodeMod
        StartLine = .CountOfDeclarationLines + 1
        Do Until StartLine >= .CountOfLines
            ReDim Preserve aList(1 To 3, 1 To x - 1)
            aList(1, x - 1) = wbk
            aList(2, x - 1) = VBComp
            aList(3, x - 1) = .ProcOfLine(StartLine, vbext_pk_Proc)
            x = x + 1
            StartLine = StartLine + .ProcCountLines(.ProcOfLine(StartLine, _
                                            vbext_pk_Proc), vbext_pk_Proc)
            If Err Then Exit Sub
        Loop
    End With
    Set VBCodeMod = Nothing
End Sub

[此贴子已经被作者于2006-9-27 15:38:33编辑过]

Emily

不可以选择或编辑单元格

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim Myrange As Range, KeepOut As Range
    Dim ws As Worksheet
    
    'Full sheet
    'Set KeepOut = ActiveSheet.Cells
    'Several Columns
    'Set KeepOut = ActiveSheet.Range("B:D")
    'Test Range
    Set KeepOut = ActiveSheet.Range("A2:C5")
        
    Set Myrange = Intersect(Target, KeepOut)
    'Leave if the intersecttion ws untouched
    If Myrange Is Nothing Then Exit Sub

    'Stop select firing a second time
    Application.EnableEvents = False
    If KeepOut.Rows.Count = 65536 And KeepOut.Columns.Count = 256 Then
        'Entire sheet is the KeepOut range. Eek!
        'Bounce user to a dummy sheet
        On Error Resume Next
        Set ws = ThisWorkbook.Sheets("KickMeTo")
        On Error GoTo 0
        If ws Is Nothing Then
            Set ws = ThisWorkbook.Sheets.Add
            ws.Name = "KickMeTo"
        End If
        MsgBox "Houston we have a problem" & vbNewLine & _
               "You cannot select any cell in " & vbNewLine & "'" & KeepOut.Parent.Name & "'" & vbNewLine & _
               "So you have been directed to a different sheet"
        ws.Activate
    ElseIf KeepOut.Rows.Count = 65536 Then
        'If all rows are contained in the "KeepOut" range then:
        'Now we need to find a cell that is in a column to the right or left of this range
        If KeepOut.Cells(1).Column > 1 Then
            'If there is a valid column to the left of the range then select the cell in this column
            Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column - 1).Select
        Else
            'Else select the cell in first column to the right of the range
            Cells(KeepOut.Cells(1).Row, KeepOut.Cells(1).Column + 1).Select
        End If
          MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
          "You have been directed to the first free column in the protected range", vbCritical
    ElseIf KeepOut.Rows.Count + KeepOut.Cells(1).Row - 1 = 65536 Then
        'Select first cell in Column A before "KeepOut" Range
        Cells(KeepOut.Cells(1).Row - 1, 1).Select
          MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
          "You have been directed to the first free cell in Column A above the protected range", vbCritical
    Else
        'Select first cell in Column A beyond "KeepOut" Range
    MsgBox "You cannot select " & KeepOut.Address(False, False) & vbNewLine & _
          "You have been directed to the first free cell in Column A below the protected range", vbCritical
        Cells(KeepOut.Rows.Count + KeepOut.Cells(1).Row, 1).Select
    End If
    Application.EnableEvents = True
End Sub

[此贴子已经被作者于2006-9-27 15:38:58编辑过]

Emily

MicroSoft 沒有文件顯示 編碼 的大小限制
64K 太大，很難跟進

以下編碼檢示 Module 的大小

Sub get_Mod_Size()
Dim myProject As Object
Dim ComName As String
Dim tempPath As String
Dim fs As Object, a As Object
Dim result As String

' **************************************************************************************
' Use this to determine the size of a module
' Set ModName (component name) and tempPath (where to store the temp fule), then run
' **************************************************************************************

' Set these to run
ComName = "Module1"
tempPath = "c:\Test.bas"

' ***** No action needed after this point *****

' Export the component (module, form, etc) - this is only temporary
Set myProject = Application.VBE.ActiveVBProject.VBComponents
myProject(ComName).Export (tempPath)

' Get the size of the file created
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.getfile(tempPath)
result = ComName & " uses " & (a.Size / 1000) & " KB."

' Return the file size
MsgBox result, vbExclamation

' Delete the exported file
fs.Deletefile tempPath

End Sub

[此贴子已经被作者于2006-9-27 15:39:14编辑过]

sblisb

好贴，怎么沉了，顶一下

学习中

mkb

全部都是精品中的精品

lotustower

以下是引用mkb在2005-10-7 21:32:00的发言： 全部都是精品中的精品

是嗎

可惜再沒有了 !!!

danielcm

好贴、好贴。感谢Emily，让我学会了不少知识。

顶一下，不能让他沉了。

壬卜

非常感谢！

xiaoqiu

支持，学习了

baoshishang

这个不错,很有帮助.