老问题，但解决不了，关于msflexgrid导出EXCEL并打印的问题

Question

用一般的办法是实现了导了EXCEL并可以打印，但是速度太慢，后来把msflexgrid的数据存到一个数组里，
但在如何选定EXCEL表一个范围，然后再把数组赋值给这一范围的时候就搞不定了……请大家帮帮，最好详细些， 谢谢，

Answer 1

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.就调整了位置.

Answer 2

谢谢楼上的，不过，这样不行，太慢了，
这是直接从msflexgrid导入的
        For i = 0 To MSFlexGrid1.Rows - 1
        
            MSFlexGrid1.row = i
            ProgressBar1.value = i
            For j = 0 To 38
            
                MSFlexGrid1.Col = j
                
                .Sheets(1).Cells(i + 1, j + 1).value = CStr(MSFlexGrid1.Text)
                
            Next j
            
        Next i
这是将msflexgrid数据导成一个二维数组 a(b, d)
.Sheets(1).Cells(b + 2, d + 2).value = a(b, d)
但还是用到了FOR NEXT
我的意思是能否把EXCEL的一个范围变成数组，这样看能否快些......

Answer 3

这个非常好用：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
                
            Next
        End With
   x.Visible = True
   
End Sub
===============================
在导出时调用，写以下代码即可：
Screen.MousePointer = vbHourglass
ExportDataTo MSFGQueryPay
Screen.MousePointer = vbDefault

Answer 4

用excel就是快不了，你说的方案，好像是没有

Answer 5

谢谢楼上各位，不过，导出EXCEL并不慢，就是加了打印之后就不行了，

Answer 6

我改成这样后，速是快了，但打印预览里没有数据，但行数和列数都有……郁闷ActiveSheet.Range("a3").value = a(b, d)'a(b, d)是msflexgrid数据生成的数组

Answer 7

ActiveSheet.Range("a3").value = a(b, d)这个方法要比循环中第次都去访问一下cells效率高出许多，这个在MSDN上就有示例

Answer 8

谢谢vbman2003(家人) 但是找不到示例啊，能否告之？

Answer 9

我在asp.net中一直是这样使用的，刚才修改了一下代码，这个在VB6下通过：    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)
    
    oSheet.Range("A1").Value = "列1"
    oSheet.Range("B1").Value = "列2"
    oSheet.Range("C1").Value = "列3"
    oSheet.Range("D1").Value = "列4"
            
    oSheet.Range("A2").Resize(fg.Rows - 1, fg.Cols - 1).Value = DataArray
    oExcel.Visible = True    Set oSheet = Nothing
    Set oBook = Nothing
    oExcel.Quit
    Set oExcel = Nothing
msdn上的相关内容我试试找一下，都是以前看的了

Answer 10

http://support.microsoft.com/kb/306022/
主要是VB.NET的，可以参考一下

Answer 11

谢谢vbman2003(家人)，我要下午再试。

Answer 12

’通用类
’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

Answer 13

'怎样调用：
'Example:
FlexGrd_SaveToExcel MSFlexGrid1, "The Header", "The Footer", 1, 16, App.Path & "\ms_masthead_10x7a_ltr.bmp", , , 37, 35, True

Answer 14

'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 excelStatic 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 IntegerDim rowOffset As Long
Dim TempStr() As String
Set objExcelDel = CreateObject("Excel.application")If Err.Number <> 0 Then
Set objExcelDel = New Excel.ApplicationErr.Clear
End If
On Error Resume Next
objExcelDel.Visible = FalseIf Len(sHeader) > 0 Then
TempStr = Split(sHeader, vbTab)
rowOffset = UBound(TempStr) + 1
End IfSet objWorkbookDel = objExcelDel.Workbooks.Add'Turn off the alerts
objExcelDel.DisplayAlerts = False'Set objWorksheet to the remaining worksheet.
Set objWorksheetDel = objExcelDel.ActiveSheetWith 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 lRowIf 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 WithHeadRange = 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.RowsFor 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 <> "" ThenG = 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 IfIf Len(CoLogoPicLocation) > 0 Then
   Set PicObject = objWorksheetDel.Pictures.Insert(CoLogoPicLocation)
  End IfobjWorksheetDel.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 IfEnd With
objExcelDel.Visible = True
objExcelDel.DisplayAlerts = True
Set objWorksheetDel = Nothing
Set objWorkbookDel = Nothing
Set objExcelDel = Nothing
End Function

Answer 15

谢各位尤其是vbman2003(家人) ( ) 
终于搞定了。
结贴