excelreports.bas

c#设计模式WithCla

Attribute VB_Name = "ExcelReports"
Option Explicit
Option Base 1      'All array indexes start with 1
'(c) 1993-1998 MicroGold Software, Inc.
'Set Tools-Options-Editor All Boxes Checked
'Set Tools-Options-General Break On All Errors

Sub ExcelCreateClassReport()

 On Error GoTo ErrorHandler
        
    Dim ClassTitleCell As Object
    Dim ClassDescriptionCell As Object
        
' ************** With Class Variables ***************
        
    Dim wcDocument As Object
    Dim h As Integer
    Dim I As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim iFileID As Integer
    Dim m As Integer
    Dim iParameterCount As Integer
    Dim iCounter As Integer
    Dim iAttrCounter As Integer
    Dim iOperCounter As Integer
    Dim iRelCounter As Integer
    Dim iIncludeCounter As Integer
    
    Dim currentAttribute As Object
    Dim currentOperation As Object
    Dim currentClass As Object
    Dim CurrentRelation As Object
    Dim currentBaseClass As Object
    Dim CurrentAggregationClass As Object
    Dim CurrentAssociationClass As Object
    
    Dim AttributeList As Object
    Dim OperationList As Object
    Dim ClassList As Object
    Dim RelationList As Object
    Dim BaseClassList As Object
    Dim AggregationClassList As Object
    Dim AssociationClassList As Object
 
    Dim sFileName As String
    Dim sInfile As String
    Dim sCellNum As String
    Dim iRowCount As Integer
    Dim iColCount As Integer
    Dim sMsg As String
        
        
' *************** Excel Variables ****************
Dim ThisExcel As Object
Dim TitleArray As Variant
Dim DataArray As Variant
' ****************************************

    iFileID = FreeFile
    iRowCount = 2
    
Set wcDocument = ActiveDocument

TitleArray = Array("Name", "Description", "Package", "Stereotype", "Visibility", "ImportFile", "LibraryBaseClass")
Set ThisExcel = CreateObject("Excel.Application")
With ThisExcel
    .Workbooks.Add
    .Range("A1:G1").Value = TitleArray
    .Range("A1:G1").Font.Bold = True
    .Range("A1").ColumnWidth = 20
    .Range("B1").ColumnWidth = 50
    .Range("C1").ColumnWidth = 20
    .Range("D1").ColumnWidth = 15
    .Range("E1").ColumnWidth = 15
    .Range("F1").ColumnWidth = 15
    .Range("G1").ColumnWidth = 15
    .Range("H1").ColumnWidth = 15
    .Range("I1").ColumnWidth = 15
    .Range("J1").ColumnWidth = 15
    .Visible = True
    
    Set ClassList = wcDocument.Classes
    iCounter = ClassList.Count
    ClassList.Restart
    While (ClassList.IsLast = False)
        iColCount = 1
        Set currentClass = ClassList.GetNext
        
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.Name
        
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.Description
        
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.Package
        
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.Stereotype
        
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.Visibility
       
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.ImportFileName
   
        iColCount = iColCount + 1
        sCellNum = GetCellString(iRowCount, iColCount)
        .Range(sCellNum).Value = currentClass.LibraryBaseClass
   
        iRowCount = iRowCount + 1
    Wend
     
End With
        
MsgBox ("Finished Creating Excel Spreadsheet")
Exit Sub

ErrorHandler:
   sMsg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
   MsgBox sMsg, , "Error", Err.HelpFile, Err.HelpContext
End Sub

Function GetCellString(row As Integer, col As Integer) As String
  On Error GoTo ErrorHandler
  
    Dim sCellNum As String
    Dim sChar1 As String
    Dim sChar2 As String
    Dim vAscrows As Variant
    Dim sMsg As String
    vAscrows = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "BB", "CC", "DD", "EE", "FF")
    sChar1 = vAscrows(col - 1)
    sChar2 = CStr(row)
    sCellNum = sChar1 & sChar2
    GetCellString = sCellNum
Exit Function

ErrorHandler:
   sMsg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & Err.Description
   MsgBox sMsg, , "Error", Err.HelpFile, Err.HelpContext
 
End Function