我正在导入一种CSV安全文件，以便在Excel中进行报告。该文件基本上具有以下格式：
!Users
UserA
UserB
UserC
...
!Roles
RoleA
RoleB
RoleC
...
!Permissions
UserA|RoleA
UserA|RoleB
UserC|RoleA
UserB|RoleC
...
报告是一种看起来像这样的矩阵：
| A | B | C | D
--|--------------|--------------|--------------|----------------
1 | | RoleA | RoleB | RoleC
2 | UserA | Y | Y | N
3 | UserB | N | N | Y
4 | UserC | Y | N | N
我能想到的最简单的方法是执行以下步骤：
Scripting.Dictionary打开文件并将所有内容放入3个多级词典（一个用于用户，一个用于角色，一个用于权限）。显然，实际的文件格式和实现有点复杂，但这是它的要点。
它适用于最大约10Mb的文件，但是当文件开始超过该数量（数千个用户和角色）时，我收到以下错误：
Run-time error '430':
Class does not support Automation or does not support expected interface
这发生在以下行：
Set pubSecClassAccess.Item(vClass).Item(vValue).Item(vUser) = New Scripting.Dictionary
如果我查看进程，EXCEL.EXE在抛出错误的位置使用大约1.5Gb的RAM。如果我结束，而不是调试然后关闭工作簿，我收到以下消息：
Excel cannot complete this task with available resources. Choose less data or close other applications.
我猜我的内存耗尽，即使我还有大约4Gb的8Gb可用。
我的问题是：我如何重新考虑我的代码，以便在不使用这么多RAM的情况下实现这一点？
文件中的部分可能采用不同的顺序（例如，!Permissions可能会出现在!Users部分之前）。
答案 0 :(得分：1)
编辑忘了说：宏需要大约一分钟来处理我的55 Mb测试文件。
我找不到任何关于字典的内存要求。但是，因为＆＃34;它在我进行排序之前抛出了错误的方式，但是字典处理方式没有任何小的改进会有所帮助。我的技术完全不同。
我首先生成了一个具有以下特征的测试文件：
结果文件接近55 Mb，包含超过一百万个权限。我不打算创建这么大的文件，但没有充分考虑每个用户平均25个权限的影响。我应该承认该文件包含重复的权限。下面的宏允许此错误并跳过重复项。
我的代码有几个步骤：
我可以用Excel打开Report.txt（21Mb）并整理格式。
下面有两个模块。第一个包含上述宏。第二个包含我在流程完成时使用的例程。
Option Explicit
Sub CreateReport()
Dim FileName As Variant
Dim FlIn As Object
Dim FlLine As String
Dim FlLinePart() As String
Dim FlOut As Object
Dim FlSysObj As Object
Dim Found As Boolean
Dim InxProc As Long
Dim NumPermissions As Long
Dim NumRoles As Long
Dim NumUsers As Long
Dim PathCrnt As String
Dim Process() As String
Dim Roles() As String
Dim RoleCrnt As Long
Dim RoleNameLast As String
Dim TimeNow As Double
Dim Users() As String
Dim UserCrnt As Long
Dim UserNameLast As String
Dim StartTime As Double
StartTime = Timer
' I find it convenient to have all files in the same folder as the workbook
' Change PathCrnt as required
PathCrnt = ActiveWorkbook.Path & "\"
' Delete any files left by previous run of macro
' Replace Report.txt by your name for output file
' =====================================================================================
For Each FileName In Array("Users.txt", "Roles.txt", "Perms.txt", _
"SortedUsers.txt", "SortedRoles.txt", "SortedPerms.txt", _
"SortUsers.bat", "SortRoles.bat", "SortPerms.bat", _
"Report.txt")
If Dir$(PathCrnt & FileName) <> "" Then
Kill PathCrnt & FileName
End If
Next
' Split security log into three separate files: Users.txt, Roles.txt and Perms.txt
' =====================================================================================
Set FlSysObj = CreateObject("Scripting.FileSystemObject")
Set FlIn = FlSysObj.OpenTextFile(PathCrnt & "testfile.txt", 1, False, 0)
FlLine = FlIn.ReadLine
Debug.Assert FlLine = "!Users"
NumUsers = 0
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "Users.txt", 2, True, 0)
Do While Not FlIn.AtEndOfStream
FlLine = FlIn.ReadLine
If FlLine <> "" Then
If FlLine = "!Roles" Then
Exit Do
End If
NumUsers = NumUsers + 1
FlOut.WriteLine FlLine
End If
Loop
FlOut.Close
Debug.Assert FlLine = "!Roles"
NumRoles = 0
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "Roles.txt", 2, True, 0)
Do While Not FlIn.AtEndOfStream
FlLine = FlIn.ReadLine
If FlLine <> "" Then
If FlLine = "!Permissions" Then
Exit Do
End If
NumRoles = NumRoles + 1
FlOut.WriteLine FlLine
End If
Loop
FlOut.Close
Debug.Assert FlLine = "!Permissions"
NumPermissions = 0
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "Perms.txt", 2, True, 0)
Do While Not FlIn.AtEndOfStream
FlLine = FlIn.ReadLine
If FlLine <> "" Then
NumPermissions = NumPermissions + 1
FlOut.WriteLine FlLine
End If
Loop
FlOut.Close
FlIn.Close
' Create batch files to sort Users.txt, Roles.txt and Perms.txt
' I have successfully used Shell with command line parameters but not tonight
' Decided not to waste time investigating my error
' ===============================================================================================
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "SortUsers.bat", 2, True, 0)
FlOut.Write "Sort <""" & PathCrnt & "Users.txt"" >""" & PathCrnt & "SortedUsers.txt"""
FlOut.Close
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "SortRoles.bat", 2, True, 0)
FlOut.Write "Sort <""" & PathCrnt & "Roles.txt"" >""" & PathCrnt & "SortedRoles.txt"""
FlOut.Close
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "SortPerms.bat", 2, True, 0)
FlOut.Write "Sort <""" & PathCrnt & "Perms.txt"" >""" & PathCrnt & "SortedPerms.txt"""
FlOut.Close
' Sort Users.txt, Roles.txt and Perms.txt to create sorted versions
' ===============================================================================================
Call Shell(PathCrnt & "SortUsers.bat")
Call Shell(PathCrnt & "SortRoles.bat")
Call Shell(PathCrnt & "SortPerms.bat")
' Loop until all the btach files have been completed
' ===============================================================================================
Do While True
Found = False
Call GetProcessList(Process)
For InxProc = 1 To UBound(Process)
If Process(InxProc) = "cmd.exe" Then
Found = True
Exit For
End If
Next
If Not Found Then
Exit Do
End If
TimeNow = Now()
' Wait 1 second
Application.Wait TimeSerial(Hour(TimeNow), Minute(TimeNow), Second(TimeNow) + 1)
Loop
' Read SortedUsers.txt and SortedRoles.txt into arrays
' ===============================================================================================
Set FlIn = FlSysObj.OpenTextFile(PathCrnt & "SortedUsers.txt", 1, False, 0)
ReDim Users(1 To NumUsers)
For UserCrnt = 1 To NumUsers
Users(UserCrnt) = FlIn.ReadLine
Next
FlIn.Close
Set FlIn = FlSysObj.OpenTextFile(PathCrnt & "SortedRoles.txt", 1, False, 0)
ReDim Roles(1 To NumRoles)
For RoleCrnt = 1 To NumRoles
Roles(RoleCrnt) = FlIn.ReadLine
Next
FlIn.Close
' Read SortedPerms.txt and generate Report.txt
' ===============================================================================================
Set FlIn = FlSysObj.OpenTextFile(PathCrnt & "SortedPerms.txt", 1, False, 0)
' Replace Report.txt" with your name for the output file
Set FlOut = FlSysObj.OpenTextFile(PathCrnt & "Report.txt", 2, True, 0)
' Create and output header row
FlLine = """User"""
For RoleCrnt = 1 To NumRoles
FlLine = FlLine & ",""" & Roles(RoleCrnt) & """"
Next
FlOut.WriteLine FlLine
UserCrnt = 0
RoleCrnt = 0
UserNameLast = ""
RoleNameLast = ""
FlLine = ""
' Output header row within do loop
Do While Not FlIn.AtEndOfStream
FlLinePart = Split(FlIn.ReadLine, "|")
Debug.Assert UBound(FlLinePart) = 1
If FlLinePart(0) = UserNameLast And FlLinePart(1) = RoleNameLast Then
' My test file contains some duplicate permissions
Else
' Process good permission
If FlLinePart(0) <> UserNameLast Then
' New user or first permission
If FlLine <> "" Then
' Output line for last user
If RoleCrnt = NumRoles Then
' Last role already output
Else
' Add Ns for remaining roles
FlLine = FlLine & Replace(String(NumRoles - RoleCrnt, "N"), "N", ",N")
End If
FlOut.WriteLine FlLine
End If
UserCrnt = UserCrnt + 1
FlLine = Users(UserCrnt) ' Initialise line for new user
RoleCrnt = 0
End If
Do While FlLinePart(0) > Users(UserCrnt)
' This user has no permissions. Output line of Ns for it
FlLine = FlLine & Replace(String(NumRoles, "N"), "N", ",N")
FlOut.WriteLine FlLine
UserCrnt = UserCrnt + 1
FlLine = Users(UserCrnt)
Loop
If FlLinePart(0) < Users(UserCrnt) Then
Debug.Assert False
' User for this permission does not appear in user list
' Assume this should not be possible.
' Output error message if it does
Else
' Have permission for current user
' Find entry in Roles() for permiisoin's role
Do While True
RoleCrnt = RoleCrnt + 1
If FlLinePart(1) > Roles(RoleCrnt) Then
' This user does not have this current role
FlLine = FlLine & ",N"
ElseIf FlLinePart(1) < Roles(RoleCrnt) Then
Debug.Assert False
' Role for this permission does not appear in role list
' Assume this should not be possible.
' Output error message if it does
Else
' This user has this permission
FlLine = FlLine & ",Y"
Exit Do
End If
Loop
End If
End If
UserNameLast = FlLinePart(0)
RoleNameLast = FlLinePart(1)
Loop ' For each permission
' Add Ns for remaining roles
FlLine = FlLine & Replace(String(NumRoles - RoleCrnt, "N"), "N", ",N")
FlOut.WriteLine FlLine ' Output final line
FlOut.Close
Debug.Print Format(Timer - StartTime, "#,##0.0")
End Sub
Option Explicit
' Source http://vbadud.blogspot.co.uk/2007/06/show-all-processes-using-vba.html
' Modified by Tony Dallimore
Const TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8
Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or _
TH32CS_SNAPPROCESS Or _
TH32CS_SNAPTHREAD Or _
TH32CS_SNAPMODULE)
Const TH32CS_INHERIT = &H80000000
Const MAX_PATH As Integer = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" _
(ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
' API Functions to get the processes
Private Declare Function Process32First Lib "kernel32" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" _
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Public Sub GetProcessList(Process() As String)
Dim hSnapShot As Long '* Handle
Dim uProcess As PROCESSENTRY32 '* Process
Dim lRet '* Return Val
Dim InxP As Long
Dim Pos As Long
ReDim Process(1 To 100)
InxP = 0 ' Array is empty
' On Error Resume Next
' Takes a snapshot of the running processes and the heaps, modules,
' and threads used by the processes
hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
uProcess.dwSize = Len(uProcess)
' Retrieve information about the first process encountered in our system snapshot
' uProcess.szExeFile is a fixed length string of 260 characters. Each new process
' name is terminated with &H0 and overwrites the previous name. Hence the need to
' discard the first &H0 and any characters that follow.
' In the original code, the first process name was ignored. During my
' experimentation, the first name was always "[System Process]" which appears to be
' a header. I continue to discard the first process name
' In the original code, the final lRet was output before being tested to be true.
' This meant the last name was junk. I always test lRet before extracting the name.
lRet = Process32First(hSnapShot, uProcess) ' Ignore "[System]"
lRet = Process32Next(hSnapShot, uProcess)
' lRet is 0 or 1. 1 means uProcess has been loaded with another process.
Do While lRet
InxP = InxP + 1
If InxP > UBound(Process) Then
ReDim Preserve Process(1 To UBound(Process) + 100)
End If
Pos = InStr(1, uProcess.szExeFile, Chr$(0))
If Pos > 0 Then
Pos = Pos - 1
Else
Pos = 0
End If
Process(InxP) = Left$(uProcess.szExeFile, Pos)
lRet = Process32Next(hSnapShot, uProcess)
Loop
CloseHandle hSnapShot
' This ReDim assumes there is at least one process.
ReDim Preserve Process(1 To InxP) ' Discard empty entries
End Sub