excelfile.cls

《管状换热器计算机辅助设计系统ExhCAD绘图系统(版本:1.01a Final)》为自由软件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 1  'vbDataSource
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ExcelFile"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'**********************************************************
'    File Name      :     excelfile.cls
'    Author         :     endlessfree
'    Last updated   :     10.05.2002
'    Compiler       :     Visucal Basic 6.0
'    Description    :     ExhCAD0.99.1生成工作表文件
'**********************************************************
'
'
'**********************************************************
'函数                         *功能描述
'**********************************************************
'FillExcelSheet              *写入工作表数据项
'FillExcelLables             *写入工作表字段名
'SheetView                   *显示工作表
'MakeExcelFile               *生成工作表文件
'**********************************************************

Option Explicit

Dim ExcelSheet      As Excel.Application

Dim LableNo         As Integer
Dim ExcelColNo      As Integer
Dim ExcelCel        As String
Dim ExcelRow        As Integer
Dim ColNoDB         As Integer
Dim RowNoDB         As Integer
Dim LineWidth       As Byte

Dim NumberOfColumns As Integer
Dim Counter         As Integer
Dim BackCounter     As Integer
Dim CaptionString   As String
Dim HeadColName     As String

Dim FieldsCounter   As Integer

Private Const ExcelColumn_B = 98


Private Sub FillExcelSheet(ArrayValues() As String, No As Integer)

On Error GoTo ErrHandler

Worksheets("sheet" + CStr(No)).Activate

ExcelColNo = ExcelColumn_B
ExcelCel = Empty
ColNoDB = 0
RowNoDB = 0
ExcelRow = 2

For ColNoDB = 0 To FieldsCounter
    
       For RowNoDB = LBound(ArrayValues) To UBound(ArrayValues)
            ExcelCel = UCase(Chr(ExcelColNo)) & 2 + ExcelRow
            ExcelSheet.Range(ExcelCel).Value = ArrayValues(RowNoDB, ColNoDB)
            ExcelRow = ExcelRow + 1
        Next RowNoDB
    ExcelRow = 2
    ExcelColNo = ExcelColNo + 1
    ExcelCel = Empty
Next ColNoDB


Exit Sub
ErrHandler:
     MsgBox Err.Number & vbCrLf & Err.Description
End Sub


Private Sub FillExcelLables(ExhCADFields() As String, No As Integer)

On Error GoTo ErrHandler


Worksheets("sheet" + CStr(No)).Activate

BackCounter = 0
ExcelColNo = ExcelColumn_B
For LableNo = 0 To UBound(ExhCADFields)
   
    ExcelCel = UCase(Chr(ExcelColNo)) & 3
    
  
    HeadColName = ExhCADFields(LableNo)
    
  
    ExcelSheet.Range(ExcelCel).Value = HeadColName
   
    ExcelColNo = ExcelColNo + 1
    BackCounter = BackCounter + 1
Next LableNo

   
    FieldsCounter = UBound(ExhCADFields)

Exit Sub
ErrHandler:
     MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Public Function MakeExcelFile(ExhCADTitles() As String, _
                              ExhCADFields() As String, _
                              SetupValues() As String, _
                              ComputeValues() As String, _
                              DrawValues() As String, _
                              szfilename As String)
 
    
    On Error GoTo ErrHandler
    

    Dim i As Integer
    
    Set ExcelSheet = CreateObject("excel.application")
     
    ExcelSheet.Workbooks.Add
  
    LableNo = 0
      
    For i = 1 To 3
  
         FillExcelLables ExhCADFields, i
    
    Next i

   
    FillExcelSheet SetupValues, 1
    FillExcelSheet ComputeValues, 2
    FillExcelSheet DrawValues, 3

   
    For i = 1 To 3
         SheetView ExhCADTitles, i
    Next i
    
  

    
    ExcelSheet.AlertBeforeOverwriting = False
    ExcelSheet.ActiveWorkbook.SaveAs szfilename
       
    ExcelSheet.Visible = True
    
  
    ExcelSheet.Quit
    
    
    Set ExcelSheet = Nothing
    
    Exit Function
ErrHandler:

    ExcelSheet.Quit
    MsgBox Err.Number & vbCrLf & Err.Description
    Set ExcelSheet = Nothing
    
End Function

Private Function SheetView(ExhCADTitles() As String, _
                           No As Integer)

On Error GoTo ErrHandler
    
    Dim CellRange As String
    Worksheets("sheet" + CStr(No)).Activate
   
    CellRange = "B3:" & UCase(Chr(FieldsCounter + ExcelColumn_B)) & "3"

  With ExcelSheet
    .Range(CellRange).Font.Bold = True
    .Range(CellRange).Font.Size = 13
    .Range(CellRange).Font.Color = vbRed
    .Range(CellRange).Font.Italic = True
    .Range(CellRange).Font.Underline = True

 
    .Range(CellRange).Borders(xlEdgeLeft).LineStyle = xlContinuous
    .Range(CellRange).Borders(xlEdgeLeft).Weight = xlMedium
    .Range(CellRange).Borders(xlEdgeLeft).ColorIndex = 32
    
    .Range(CellRange).Borders(xlEdgeTop).LineStyle = xlContinuous
    .Range(CellRange).Borders(xlEdgeTop).Weight = xlMedium
    .Range(CellRange).Borders(xlEdgeTop).ColorIndex = 32
    
    .Range(CellRange).Borders(xlEdgeBottom).LineStyle = xlContinuous
    .Range(CellRange).Borders(xlEdgeBottom).Weight = xlMedium
    .Range(CellRange).Borders(xlEdgeBottom).ColorIndex = 32

    .Range(CellRange).Borders(xlEdgeRight).LineStyle = xlContinuous
    .Range(CellRange).Borders(xlEdgeRight).Weight = xlMedium
    .Range(CellRange).Borders(xlEdgeRight).ColorIndex = 32


    .Range(CellRange).HorizontalAlignment = xlRight
    .Range(CellRange).VerticalAlignment = xlBottom
    
    .Columns.AutoFit
    

    .Range(CellRange).Interior.Color = vbYellow
    

    .Range("A3").Select
    .Columns("A:A").ColumnWidth = 20
    End With
    
    Worksheets("sheet" + CStr(No)).Name = ExhCADTitles(No - 1)
   
Exit Function
ErrHandler:
    ExcelSheet.Quit
    MsgBox Err.Number & vbCrLf & Err.Description
    Set ExcelSheet = Nothing
End Function