cexcel.cls

zui hao yong de VBxitong

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CEXCEL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'类名称：CEXCEL
'作者： 大脚
Option Explicit

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As String) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Any, lParam As Any) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long

Private Const WM_DESTROY = &H2
Private Const WM_QUIT = &H12
Private Const WM_CLOSE = &H10
Private Const GW_CHILD = 5
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDLAST = 1
Private Const GW_HWNDNEXT = 2
Private Const GW_HWNDPREV = 3
Private Const GW_OWNER = 4
Private Const WM_GETTEXT = &HD
Private Const WM_GETTEXTLENGTH = &HE

Private Const WM_DDE_FIRST = &H3E0
Private Const WM_DDE_EXECUTE = (WM_DDE_FIRST + 8)
Private Const WM_DDE_INITIATE = (WM_DDE_FIRST)


Private Const ID_CAPTION = "CEXCEL_导出调用"
Private Const TEMPFILENAME = "CEXCEL.tmp"


Dim zsbExcel As Object
Dim zsbWorkbook As Object

Private Sub Class_Initialize()
    'Set zsbExcel = CreateObject("Excel.Application")
    'Set zsbWorkbook = CreateObject("Excel.Workbook")
End Sub


'******************************************
'grid               要导出的表格
'showCol            要显示的列，如果为空，则显示所有列
'sumCol             要合计的列
'FirstRowInExcel    Excel里面开始写的行,默认为第一行
'FirstColInExcel    Excel里面开始写得列,默认为第一列
'ShowHead           是否显示表格的列首，如果在模板文件里写入了列首的话，该值应该为false
'******************************************
Public Function MSHFlexGridToExcel(Grid As MSHFlexGrid, showCol As String, sumCol As String, _
                         Optional ByVal FirstRowInExcel As Long = 1, _
                         Optional ByVal FirstColInExcel As Long = 1, _
                         Optional ShowHead As Boolean = True) As Boolean
Dim tempCol() As String
Dim tempSum() As String
Dim cols As Long
Dim colStr(0 To 26 * 27 - 1) As String '得到26列的字母
Dim i As Long, j As Long
Dim rows As Long
    tempCol = Split(showCol, "|")
    If showCol = "" Then
        ReDim tempCol(Grid.cols - 1)
        For i = 0 To Grid.cols - 1
            tempCol(i) = i
        Next i
    End If
    cols = UBound(tempCol) + 1 '得到有多少个列
    '得到所有列的字母，共26*27列
    For i = 0 To 25
        colStr(i) = Chr(Asc("a") + i)
    Next i
    For j = 1 To 26
        For i = 0 To 25   '"AA-AZ"
            colStr(j * 26 + i) = Chr(Asc("a") + j - 1) & Chr(Asc("a") + i)
        Next i
    Next j
    '得到要写入Excel的有多少个行
    rows = Grid.rows - IIf(ShowHead, 0, Grid.FixedRows)
Dim temp() As String
    ReDim temp(rows - 1, cols - 1)
    '****读取表格内容到数组
    Grid.Redraw = False
    For i = 0 To rows - 1
        For j = 0 To cols - 1
            Grid.Col = tempCol(j)
            Grid.Row = i + IIf(ShowHead, 0, Grid.FixedRows)
            temp(i, j) = Grid.Text
        Next j
    Next i
    Grid.Redraw = True
    '****将数组写入excel
    zsbExcel.Range(colStr(FirstColInExcel - 1) & FirstRowInExcel, colStr(cols + FirstColInExcel - 2) & rows + FirstRowInExcel - 1) = temp
    '写入要合计的列
Dim strSumCol As String
Dim strSumRow1 As String, strSumRow2 As String
    If sumCol <> "" Then
        tempSum = Split(sumCol, "|")
        zsbExcel.ActiveSheet.Cells(rows + FirstRowInExcel, 1).Value = "合计"
        For j = 0 To cols - 1
            For i = 0 To UBound(tempSum)
                If tempCol(j) = tempSum(i) Then
                    strSumCol = colStr(FirstColInExcel + j) '列的字母
                    strSumRow1 = FirstRowInExcel + IIf(ShowHead, Grid.FixedRows, 0) '合计的开始行
                    strSumRow2 = FirstRowInExcel + rows - 1 '合计的结束行
                    zsbExcel.ActiveSheet.Cells(rows + FirstRowInExcel, FirstColInExcel + j).Value = _
                    "=SUM(" & strSumCol & strSumRow1 & ":" & strSumCol & strSumRow2 & ")"
                End If
            Next i
        Next j
    End If
    '为数据区画上表格
    zsbExcel.Range(colStr(FirstColInExcel - 1) & FirstRowInExcel, colStr(cols + FirstColInExcel - 2) & rows - IIf(sumCol <> "", 0, 1) + FirstRowInExcel).Borders.LineStyle = 0
    zsbExcel.Range(colStr(FirstColInExcel - 1) & FirstRowInExcel, colStr(cols + FirstColInExcel - 2) & rows - IIf(sumCol <> "", 0, 1) + FirstRowInExcel).Borders.Weight = 2
End Function



Public Function OpenExcel(Optional fileName As String = "") As Boolean
    ClearAll '清除内存中的excel和临时文件
    Set zsbExcel = CreateObject("Excel.Application")
    zsbExcel.Caption = ID_CAPTION
    zsbExcel.Visible = False '设置excel为不可见
    zsbExcel.SheetsInNewWorkbook = 1
    If Len(fileName) <> 0 Then
        Call FileCopy(fileName, App.Path & "\" & TEMPFILENAME)
        Set zsbWorkbook = zsbExcel.Workbooks.Open(App.Path & "\" & TEMPFILENAME)
    Else
        Set zsbWorkbook = zsbExcel.Workbooks.Add
    End If
End Function

'写入一个单元格
Public Sub WriteSingleCell(strCell As String, strValue As String)
    On Error GoTo errout
    zsbExcel.Range(strCell).Value = strValue
errout:
End Sub

'写入一个数组
Public Sub WriteRangeCell(strCell As String, strValue() As String)
    On Error GoTo errout
    zsbExcel.Range(strCell) = strValue
errout:
End Sub

'导出Excel文件
Public Function Export(fileName As String) As Boolean
Dim rltMsgbox As VbMsgBoxResult
    On Error GoTo errout
    Export = False
    If fileName <> "" Then
        If Dir(fileName) <> "" Then
            rltMsgbox = MsgBox("该位置存在同名文件，要覆盖吗?", vbYesNo)
            If rltMsgbox = vbYes Then
                Kill (fileName)
                zsbExcel.ActiveSheet.SaveAs fileName
                Export = True
            End If
        Else
            zsbExcel.ActiveSheet.SaveAs fileName
            Export = True
        End If
    Else
        zsbWorkbook.Saved = True
    End If
errout:
End Function

'发送到打印机
Public Function ToPrint() As Boolean
    zsbExcel.ActiveSheet.PrintOut
End Function

'预览
Public Function ShowView() As Boolean
    zsbExcel.Visible = True
    zsbWorkbook.Saved = True
    zsbExcel.ActiveSheet.PrintPreview

End Function

Public Function CloseExcel()
'On Error GoTo errout
    zsbWorkbook.Saved = True
    zsbExcel.DisplayAlerts = False
    If zsbExcel.Visible = False Then
        zsbExcel.Quit
    End If
    Set zsbWorkbook = Nothing
    Set zsbExcel = Nothing
    'If Len(Dir(App.Path & "\" & TEMPFILENAME)) <> 0 Then
    '    Kill (App.Path & "\" & TEMPFILENAME)
    'End If
errout:
End Function

'*****************************
'根据窗体部分名称取得句柄
'*****************************
Private Function GetHwnd(strWinText As String) As Long
Dim l As Long, k As Long, rlt As Long
Dim strLen As Long
Dim str As String * 255
    l = GetForegroundWindow
    l = GetWindow(l, GW_HWNDFIRST)
    Do Until l = 0
        strLen = SendMessage(l, WM_GETTEXTLENGTH, 0&, 0&)
        If strLen <> 0 Then
            rlt = SendMessage(l, WM_GETTEXT, strLen + 1, ByVal str)
            If Mid(str, 1, Len(strWinText)) = strWinText Then
                GetHwnd = l
            End If
        End If
        l = GetWindow(l, GW_HWNDNEXT)
    Loop
End Function

'关闭已经打开的Excel实例
Private Sub ClearAll()
Dim lngHWnd As Long
Dim l As Long
Dim m_app As String * 255, m_topic As String * 255
Dim m_lParam As Long

    On Error GoTo errout
    lngHWnd = GetHwnd(ID_CAPTION)
    If lngHWnd <> 0 Then
        SendMessage lngHWnd, WM_CLOSE, 0&, 0&
    End If
        
    If Dir(App.Path & "\" & TEMPFILENAME) <> "" Then
        Kill App.Path & "\" & TEMPFILENAME
    End If
    Exit Sub
errout:
End Sub