Misc:Function : MSFLEXGrid to EXCEL Export

MsFLEXGrid to EXcel Export Function


Public Sub FlexGrid2Excel(TheFlexgrid As MSFlexGrid, _
Optional TheRows As Integer, Optional TheCols As Integer, _
Optional GridStyle As Integer = 1, Optional WorkSheetName _
As String)

Dim objXL As New Excel.Application
Dim wbXL As New Excel.Workbook
Dim wsXL As New Excel.Worksheet
Dim intRow As Integer ' counter
Dim intCol As Integer ' counter

Dim MrgRowStart As Integer
Dim MrgRowEnd As Integer
Dim MrgCol As Integer
Dim MrgData As String
Dim i As Integer
Dim MrgNow As String

If Not IsObject(objXL) Then
MsgBox "You need Microsoft Excel to use this function", _
vbExclamation, "Print to Excel"
Exit Sub
End If


On Error Resume Next

TheRows = TheFlexgrid.Rows
TheCols = TheFlexgrid.Cols

objXL.Visible = True
Set wbXL = objXL.Workbooks.Add
Set wsXL = objXL.ActiveSheet

' name the worksheet
With wsXL
If Not WorkSheetName = "" Then
.Name = WorkSheetName
End If
End With

' fill worksheet
For intRow = 1 To TheFlexgrid.Rows
For intCol = 1 To TheFlexgrid.Cols
With TheFlexgrid
wsXL.Cells(intRow, intCol).Value = _
.TextMatrix(intRow - 1, intCol - 1) & " "
'wsXL.Range(wsXL.Cells(intRow, intCol), wsXL.Cells(intRow, intCol)).Borders.weight = 2
End With
Next
Next

' format the look
For intCol = 1 To TheCols
wsXL.Columns(intCol).AutoFit
Next
wsXL.Range("a1", Right(wsXL.Columns(TheCols).AddressLocal, 1) & TheRows).AutoFormat xlRangeAutoFormatTable1 'GridStyle
wsXL.Range("a1", Right(wsXL.Columns(TheCols).AddressLocal, 1) & TheRows).rowheight = 24

'Merge check---
MrgRowStart = 0: MrgRowEnd = 0: MrgCol = 0
MrgData = ""
MrgNow = ""
For intCol = 1 To TheFlexgrid.Cols
For intRow = 1 To TheFlexgrid.Rows

If MrgData = wsXL.Cells(intRow, intCol) And MrgData <> "EMPTY" And Trim(MrgData) <> "" Then
MrgNow = "START"
If MrgRowStart = 0 Then
MrgRowStart = intRow - 1
End If
MrgRowEnd = intRow
MrgCol = intCol
ElseIf MrgNow = "START" And MrgData <> wsXL.Cells(intRow, intCol) Then
MrgNow = "NOW"
End If

If MrgData <> "" And MrgData <> "EMPTY" And Trim(MrgData) <> "" And MrgNow = "NOW" And MrgRowStart <> MrgRowEnd Then

For i = MrgRowStart + 1 To MrgRowEnd
wsXL.Cells(i, MrgCol) = ""
Next i
wsXL.Range(wsXL.Cells(MrgRowStart, MrgCol), wsXL.Cells(MrgRowEnd, MrgCol)).Borders.Weight = 2
wsXL.Range(wsXL.Cells(MrgRowStart, MrgCol), wsXL.Cells(MrgRowEnd, MrgCol)).WrapText = True
wsXL.Range(wsXL.Cells(MrgRowStart, MrgCol), wsXL.Cells(MrgRowEnd, MrgCol)).Font.Size = 6
wsXL.Range(wsXL.Cells(MrgRowStart, MrgCol), wsXL.Cells(MrgRowEnd, MrgCol)).Merge
MrgRowStart = 0: MrgRowEnd = 0: MrgCol = 0
MrgData = "": MrgNow = ""
End If

wsXL.Range(wsXL.Cells(intRow, intCol), wsXL.Cells(intRow, intCol)).Borders.Weight = 2
If Trim(wsXL.Cells(intRow, intCol)) <> "" Then
wsXL.Range(wsXL.Cells(intRow, intCol), wsXL.Cells(intRow, intCol)).HorizontalAlignment = xlCenter
wsXL.Range(wsXL.Cells(intRow, intCol), wsXL.Cells(intRow, intCol)).VerticalAlignment = xlCenter
End If

MrgData = IIf(wsXL.Cells(intRow, intCol) = "", "EMPTY", wsXL.Cells(intRow, intCol))
Next intRow
MrgRowStart = 0
Next intCol
wsXL.PageSetup.LeftMargin = objXL.InchesToPoints(0.4)
wsXL.PageSetup.TopMargin = objXL.InchesToPoints(0.4)
End Sub