'Revised by VBAdvisor
’通用类
’MSFlexGrid Export to MSExcel
Public Function FlexGrd_SaveToExcel(FG As MSFlexGrid, Optional sHeader As String = "", Optional sFooter As String = "", Optional ColumnHeaderFontColorIndex As Long, Optional ColumnHeaderBackColorIndex As Long, Optional CoLogoPicLocation As String, Optional WorkBkBackColorIndex As Long, Optional WorkBkGridColorIndex As Long, Optional AlternateRowColorIndex1 As Long, Optional AlternateRowColorIndex2 As Long, Optional AutoColumnFitter As Boolean)
' Autofit columns
' Alternating row colors in excel
Static objExcelDel As Object
Static objWorkbookDel As Excel.Workbook
Static objWorksheetDel As Excel.Worksheet
Static HeadRange As Excel.Range
Static NewRange As Excel.Range
Static GridRange As Range
Static PicObject As Excel.ShapeRange
Dim lRow As Integer, lCol As Integer
Dim i As Integer, J As Integer
Dim C As Integer
Dim rowOffset As Long
Dim TempStr() As String
Set objExcelDel = CreateObject("Excel.application")
If Err.Number <> 0 Then
Set objExcelDel = New Excel.Application
Err.Clear
End If
On Error Resume Next
objExcelDel.Visible = False
If Len(sHeader) > 0 Then
TempStr = Split(sHeader, vbTab)
rowOffset = UBound(TempStr) + 1
End If
Set objWorkbookDel = objExcelDel.Workbooks.Add
'Turn off the alerts
objExcelDel.DisplayAlerts = False
'Set objWorksheet to the remaining worksheet.
Set objWorksheetDel = objExcelDel.ActiveSheet
With objWorksheetDel
' Sheet Header
For lRow = 1 To rowOffset
.PageSetup.CenterHeader = TempStr(lRow - 1)
Next lRow
' Get Column Headers
For lRow = 1 To FG.FixedRows
For lCol = 1 To FG.Cols
.Cells(4, lCol - 1) = FG.TextMatrix(lRow - 1, lCol - 1)
Next lCol
Next lRow
If Val(WorkBkBackColorIndex) > 0 Then
objWorkbookDel.Styles("Normal").Interior.ColorIndex = WorkBkBackColorIndex
End If
'Gridlines will not be visible but you can add that to by
If Val(WorkBkGridColorIndex) > 0 Then
With objWorkbookDel.Styles("Normal").Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1 ' 1 is black
End With
With objWorkbookDel.Styles("Normal").Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With objWorkbookDel.Styles("Normal").Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With objWorkbookDel.Styles("Normal").Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
End If
Set HeadRange = objWorksheetDel.Range(objWorksheetDel.Cells(4, 1), _
objWorksheetDel.Cells(4, lCol - 2))
With HeadRange
'*****Sets Column Header Back Color
If Val(ColumnHeaderBackColorIndex) > 0 Then
.Interior.ColorIndex = ColumnHeaderBackColorIndex
Else
' My Default Background color for Column header index change it to what ever you want
.Interior.ColorIndex = 5
End If
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = 6
.Interior.Pattern = xlLightHorizontal
.Interior.ColorIndex = 20
.Font.Name = "Rockwell"
.Font.FontStyle = "Bold"
.Font.Shadow = True
'***** Sets Column header Font color*****
If Val(ColumnHeaderFontColorIndex) > 0 Then
.Font.ColorIndex = ColumnHeaderFontColorIndex
Else
' My Default Font color for Column header index change it to what ever you want
.Font.ColorIndex = 2
End If
.Font.Bold = True
'************************************
'Sets border colors of header. You could also add this
'to the function but I thought I was getting carried away
'as it was.
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16 'grey
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1 ' Black
End With
End With
HeadRange = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim RowCounter As Integer ' used for all alternate row color
RowCounter = 0 ' ditto
' Dim ColCounter As Integer ' used for all alternate row color
' ColCounter = 0
Dim G As Integer ' ditto
Dim Alternate As Boolean 'ditto
'''''''''''''''''''''''''''''''''''''''
' Fill excel sheet with data
' Row data from flexgrid
For i = 1 To FG.Rows
For J = 0 To FG.Cols
objWorksheetDel.Cells(i + 4, J) = FG.TextMatrix(i, J)
objWorksheetDel.Cells(i + 4, J + 1).VerticalAlignment = xlTop
Next J
RowCounter = RowCounter + 1
Next i
RowCounter = RowCounter - 1 ' Getting rid of extra row
''''''''''''''''''''''''''''''''''''''''''''''''
' Alternate row colors on Excel spreadsheet
If AlternateRowColorIndex1 <> "" And AlternateRowColorIndex2 <> "" Then
G = 0
Do Until G = RowCounter ' RowCounter is figured when row data is taken
Set NewRange = objWorksheetDel.Range(objWorksheetDel.Cells(G + 5, 1), _
objWorksheetDel.Cells(G + 5, lCol - 2))
With NewRange
If Alternate <> True Then
.Interior.ColorIndex = AlternateRowColorIndex1
.Borders.ColorIndex = 31
'Sets font color either 1 Black or 2 white for row
Select Case AlternateRowColorIndex1
Case 1, 3, 5, 9, 11, 13, 14, 16, 17, 21, 23, 25
.Font.ColorIndex = 2
Case Else
.Font.ColorIndex = 1
End Select
Alternate = True
Else
.Interior.ColorIndex = AlternateRowColorIndex2
.Borders.ColorIndex = 31
'Sets font color either 1 Black or 2 white
Select Case AlternateRowColorIndex2
Case 1, 3, 5, 9, 11, 13, 14, 16, 17, 21, 23, 25
.Font.ColorIndex = 2
Case Else
.Font.ColorIndex = 1
End Select
Alternate = False
End If
End With
NewRange = Nothing
G = G + 1
Loop
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Autofit columns
If AutoColumnFitter = True Then
.Columns.AutoFit
End If
If Len(CoLogoPicLocation) > 0 Then
Set PicObject = objWorksheetDel.Pictures.Insert(CoLogoPicLocation)
End If
objWorksheetDel.OLEObjects
' Page Footer
If Len(sFooter) > 0 Then
TempStr = Split(sFooter, vbTab)
For lRow = 0 To UBound(TempStr)
.PageSetup.CenterFooter = TempStr(lRow)
Next lRow
End If
End With
objExcelDel.Visible = True
objExcelDel.DisplayAlerts = True
Set objWorksheetDel = Nothing
Set objWorkbookDel = Nothing
Set objExcelDel = Nothing
End Function
’通用类
’MSFlexGrid Export to MSExcel
Public Function FlexGrd_SaveToExcel(FG As MSFlexGrid, Optional sHeader As String = "", Optional sFooter As String = "", Optional ColumnHeaderFontColorIndex As Long, Optional ColumnHeaderBackColorIndex As Long, Optional CoLogoPicLocation As String, Optional WorkBkBackColorIndex As Long, Optional WorkBkGridColorIndex As Long, Optional AlternateRowColorIndex1 As Long, Optional AlternateRowColorIndex2 As Long, Optional AutoColumnFitter As Boolean)
' Autofit columns
' Alternating row colors in excel
Static objExcelDel As Object
Static objWorkbookDel As Excel.Workbook
Static objWorksheetDel As Excel.Worksheet
Static HeadRange As Excel.Range
Static NewRange As Excel.Range
Static GridRange As Range
Static PicObject As Excel.ShapeRange
Dim lRow As Integer, lCol As Integer
Dim i As Integer, J As Integer
Dim C As Integer
Dim rowOffset As Long
Dim TempStr() As String
Set objExcelDel = CreateObject("Excel.application")
If Err.Number <> 0 Then
Set objExcelDel = New Excel.Application
Err.Clear
End If
On Error Resume Next
objExcelDel.Visible = False
If Len(sHeader) > 0 Then
TempStr = Split(sHeader, vbTab)
rowOffset = UBound(TempStr) + 1
End If
Set objWorkbookDel = objExcelDel.Workbooks.Add
'Turn off the alerts
objExcelDel.DisplayAlerts = False
'Set objWorksheet to the remaining worksheet.
Set objWorksheetDel = objExcelDel.ActiveSheet
With objWorksheetDel
' Sheet Header
For lRow = 1 To rowOffset
.PageSetup.CenterHeader = TempStr(lRow - 1)
Next lRow
' Get Column Headers
For lRow = 1 To FG.FixedRows
For lCol = 1 To FG.Cols
.Cells(4, lCol - 1) = FG.TextMatrix(lRow - 1, lCol - 1)
Next lCol
Next lRow
If Val(WorkBkBackColorIndex) > 0 Then
objWorkbookDel.Styles("Normal").Interior.ColorIndex = WorkBkBackColorIndex
End If
'Gridlines will not be visible but you can add that to by
If Val(WorkBkGridColorIndex) > 0 Then
With objWorkbookDel.Styles("Normal").Borders(xlLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1 ' 1 is black
End With
With objWorkbookDel.Styles("Normal").Borders(xlRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With objWorkbookDel.Styles("Normal").Borders(xlTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With objWorkbookDel.Styles("Normal").Borders(xlBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
End If
Set HeadRange = objWorksheetDel.Range(objWorksheetDel.Cells(4, 1), _
objWorksheetDel.Cells(4, lCol - 2))
With HeadRange
'*****Sets Column Header Back Color
If Val(ColumnHeaderBackColorIndex) > 0 Then
.Interior.ColorIndex = ColumnHeaderBackColorIndex
Else
' My Default Background color for Column header index change it to what ever you want
.Interior.ColorIndex = 5
End If
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = 6
.Interior.Pattern = xlLightHorizontal
.Interior.ColorIndex = 20
.Font.Name = "Rockwell"
.Font.FontStyle = "Bold"
.Font.Shadow = True
'***** Sets Column header Font color*****
If Val(ColumnHeaderFontColorIndex) > 0 Then
.Font.ColorIndex = ColumnHeaderFontColorIndex
Else
' My Default Font color for Column header index change it to what ever you want
.Font.ColorIndex = 2
End If
.Font.Bold = True
'************************************
'Sets border colors of header. You could also add this
'to the function but I thought I was getting carried away
'as it was.
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16 'grey
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 16
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1 ' Black
End With
End With
HeadRange = Nothing
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim RowCounter As Integer ' used for all alternate row color
RowCounter = 0 ' ditto
' Dim ColCounter As Integer ' used for all alternate row color
' ColCounter = 0
Dim G As Integer ' ditto
Dim Alternate As Boolean 'ditto
'''''''''''''''''''''''''''''''''''''''
' Fill excel sheet with data
' Row data from flexgrid
For i = 1 To FG.Rows
For J = 0 To FG.Cols
objWorksheetDel.Cells(i + 4, J) = FG.TextMatrix(i, J)
objWorksheetDel.Cells(i + 4, J + 1).VerticalAlignment = xlTop
Next J
RowCounter = RowCounter + 1
Next i
RowCounter = RowCounter - 1 ' Getting rid of extra row
''''''''''''''''''''''''''''''''''''''''''''''''
' Alternate row colors on Excel spreadsheet
If AlternateRowColorIndex1 <> "" And AlternateRowColorIndex2 <> "" Then
G = 0
Do Until G = RowCounter ' RowCounter is figured when row data is taken
Set NewRange = objWorksheetDel.Range(objWorksheetDel.Cells(G + 5, 1), _
objWorksheetDel.Cells(G + 5, lCol - 2))
With NewRange
If Alternate <> True Then
.Interior.ColorIndex = AlternateRowColorIndex1
.Borders.ColorIndex = 31
'Sets font color either 1 Black or 2 white for row
Select Case AlternateRowColorIndex1
Case 1, 3, 5, 9, 11, 13, 14, 16, 17, 21, 23, 25
.Font.ColorIndex = 2
Case Else
.Font.ColorIndex = 1
End Select
Alternate = True
Else
.Interior.ColorIndex = AlternateRowColorIndex2
.Borders.ColorIndex = 31
'Sets font color either 1 Black or 2 white
Select Case AlternateRowColorIndex2
Case 1, 3, 5, 9, 11, 13, 14, 16, 17, 21, 23, 25
.Font.ColorIndex = 2
Case Else
.Font.ColorIndex = 1
End Select
Alternate = False
End If
End With
NewRange = Nothing
G = G + 1
Loop
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Autofit columns
If AutoColumnFitter = True Then
.Columns.AutoFit
End If
'******************************************
objWorksheetDel.OLEObjects
' Page Footer
If Len(sFooter) > 0 Then
TempStr = Split(sFooter, vbTab)
For lRow = 0 To UBound(TempStr)
.PageSetup.CenterFooter = TempStr(lRow)
Next lRow
End If
End With
objExcelDel.Visible = True
objExcelDel.DisplayAlerts = True
Set objWorksheetDel = Nothing
Set objWorkbookDel = Nothing
Set objExcelDel = Nothing
End Function
Dim DataArray() As String
Dim r As Integer, c As Integer
ReDim DataArray(fg.Rows - 1, fg.Cols - 1)
For r = 1 To fg.Rows - 1
For c = 1 To fg.Cols - 1
DataArray(r - 1, c - 1) = fg.TextMatrix(r, c)
Next c
Next r
Dim oExcel As Object
Dim oBook As Object
Dim oSheet As Object
Set oExcel = CreateObject("Excel.Application")
Set oBook = oExcel.Workbooks.Add
Set oSheet = oBook.Worksheets(1)
Public Sub ExportDataTo(ByVal MSFG As MSFlexGrid)
Dim x As Excel.Application
Dim I As Long
Dim j As Long
Dim nCols As Long
Dim nRows As Long
Set x = CreateObject("excel.application")
x.Visible = False
nCols = MSFG.Cols
nRows = MSFG.Rows
I = 1
j = 1
Dim Book As Excel.Workbook
Set Book = x.Workbooks.Add(xlWorksheet)
With x.ActiveSheet
While I <= nRows
j = 1
While j < nCols
.Cells(I, j) = "'" + MSFG.TextMatrix(I - 1, j)
j = j + 1
Wend
I = I + 1
Wend
For j = 1 To nCols - 1
.Columns(j).AutoFit
Set VBExcel = CreateObject("Excel.Application")
With VBExcel
.Workbooks.Open App.Path + "\" + "导出.xls" 'app.path是程序的相对路径
.Visible = True
For i = 0 To Xhnum - 1
For j = 0 To Xlnum - 1
.cells(i + 2, j + 1).Value = Xssz(j, i)
Next
Next
End With
其实就是一个一个的格子写。有多大的二维数组,就写成多少范围。最左上角的那个格子确定了整个范围的位置,.cells(i + 2, j + 1)中,调整参数2或1.就调整了位置.