'*********************************************************************************************************
' Description: Export Grid or RS To Excel
' Purpose    : Export data from a grid or recordset into an excel spreedsheet
'              If grid object data will be displayed in excel exactly as what appears in the grid, any
'              columns that are hidden will remain hidden
'              If RS object data will be desplayed in excel exactly as what appears in RS, using a RS,
'              however, allows the ability to customize the data prior to calling ExportRSToExcel
' Inputs     : Grid object or Recordset object
' Written    : 06/24/03
' Updates    :  November 2007, July 2008 RJ Samp played with the Grid Output.
'*********************************************************************************************************

option explicit
Dim objExcel          'Excel object
Dim blnCurrencySymbol 'Whether or not we display the currency symbol for appropriate data types

'''' TxDataGridColumnType
CONST           ctStandard     = 0
CONST           ctMask         = 1
CONST           ctButton       = 2
CONST           ctDate         = 3
CONST           ctCheck        = 4
CONST           ctImage        = 5
CONST           ctSpin         = 6
CONST           ctCombo        = 8
CONST           ctCalculator   = 9
CONST           ctPictureBlob  = 10
CONST           ctHyperlink    = 11
CONST           ctTime         = 12
CONST           crCurrency     = 13
CONST           ctMemo         = 14
CONST           ctPickList     = 15
'''  TxAlignment
CONST           taLeftJustify  = 0
CONST           taRightJustify = 1
CONST           taCenter       = 2
'''  TxTextAlignment
CONST           tlTop          = 0
CONST           tlCenter       = 1
CONST           tlBottom       = 2

CONST           ftNone         = 0
CONST           ftFixed        = 1
CONST           ftInteger      = 2
CONST           ftDateTime     = 3
CONST           ftPerCent      = 4
CONST           ftCurrency     = 5
CONST           ftUser         = 6
CONST           ftPhone        = 7
CONST           ftOwner        = 8
CONST           ftBoolean      = 9

''RJ Samp July 2008
CONST       BigReportSize   = 25
CONST       MaxExcelRows    = 65000
DIm         TimeStart
DIM         TimeEnd
DIm         TimeUsed
DIM         ExportRows
DIM         nCols
DIM         nRows
DIM MTEXT, RowText

Sub Main
    'Initialize
    blnCurrencySymbol = True
End Sub

Sub ExportGridToExcel(objGrid, SheetName)
    Dim intRow, intCol, intRecordCount
    Dim aRows, aColCaptions
    Dim objRS

       'Get the RS from the Grid
       Set objRS = objGrid.Recordset

       'Make sure there are records
       If objRS.RecordCount < 1 Then Exit Sub

       'Move to the first record
       objRS.MoveFirst

       'Get an array of visible FieldNames in the grid, then get only those fields from the RS
       aRows = objRS.GetRows(,, GetArrayVisibleColumnNames(objGrid))

       'Get the number of records
       intRecordCount = UBound(aRows, 2) + 1
        ExportRows =  intRecordCount
       'Create reference variable for the spreadsheet. If Excel isn't found exit sub
       If Not CreateExcelObject Then Exit Sub
             if intRecordCount > BigReportSize THEN MSGBOX "Wait one, creating spreadsheet for " & intRecordCount  & " rows."
       TIMESTART = Timer
       objExcel.Visible = FALSE
       objExcel.Workbooks.Add

       'Ensure that Excel remains visible if we switch to the Active Sheet
       SetExcelActiveSheet(objExcel)
       'Set the SpreedSheet name, if specified
       If SheetName <> "" Then
          'Sheet name can be no more than 31 characters
          objExcel.Sheets(1).Name = LEFT(TRIM("" & SheetName),31)
       End If
'''''
      'Format the Column header
       'Get array of visible captions in the grid as will be displayed in Excel
       aColCaptions = GetArrayVisibleColumnCaptions(objGrid)
       intRow = 1
       intCol = 1
       For intCol = 1 To UBound(aRows, 1) + 1
        '''' RJ Samp
          objExcel.Columns(intCol).NumberFormat             = "General"   ''' GetFormatType(objGrid.Columns.Item(intCol).Format) '''Not Exposed in 6.1??
          objExcel.Columns(intCol).VerticalAlignment       = -4160 'Align Top
           With objExcel.Cells(intRow, intCol)
                .Value = aColCaptions(intCol - 1)
                IF instr(1,.VALUE, "Grade",1) > 0 THEN objExcel.Columns(intCol).NumberFormat     =  "@"
                IF  .Value = "PID" or .VALUE = "Postalcode"  or .VALUE = "Postal code"  THEN
                    objExcel.Columns(intCol).NumberFormat = "General"
                END IF
                IF instr(1,.VALUE, "Potential $",1) > 0 THEN objExcel.Columns(intCol).NumberFormat      = "$##,###.00;[Red]($##,###.00)"
                IF instr(1,.VALUE, "Discount",1) > 0    THEN objExcel.Columns(intCol).NumberFormat      = "##,##0.00% "
                IF instr(1,.VALUE, "%",1) > 0           THEN objExcel.Columns(intCol).NumberFormat      = "##,##0.00% "
                IF instr(1,.VALUE, "Enroll",1) > 0      THEN objExcel.Columns(intCol).NumberFormat      = "##,##0 "
                IF instr(1,.VALUE, "Students",1) > 0    THEN objExcel.Columns(intCol).NumberFormat      = "##,##0 "
                IF instr(1,.VALUE, "Schools",1) > 0     THEN objExcel.Columns(intCol).NumberFormat      = "##,##0 "
                IF instr(1,.VALUE, "Price",1) > 0       THEN objExcel.Columns(intCol).NumberFormat      = "$##,###.00;[Red]($##,###.00)"
                IF instr(1,.VALUE, "$",1) > 0           THEN objExcel.Columns(intCol).NumberFormat      = "$##,###.00;[Red]($##,###.00)"
                IF instr(1,.VALUE, "Amount",1) > 0      THEN objExcel.Columns(intCol).NumberFormat      = "$##,###.00;[Red]($##,###.00)"
                IF instr(1,.VALUE, "Date",1) > 0        THEN objExcel.Columns(intCol).NumberFormat      = "mm/dd/yyyy"
                IF instr(1,.VALUE, "Start",1) > 0       THEN objExcel.Columns(intCol).NumberFormat      = "mm/dd/yyyy"
                IF instr(1,.VALUE, "End",1) > 0         THEN objExcel.Columns(intCol).NumberFormat      = "mm/dd/yyyy"
'''''''__________________________________________________
                With .Font
                     .Name = "Arial"  'DNL
                     .Bold = True
                     .Size = 9
                End With
           End With
       Next
              IF EXPORTROWS > MaxExcelROWS - 2 THEN EXPORTROWS = MaxExcelROWS - 2
if intRecordCount <= BigReportSize THEN

       'Add records
       With objExcel
            For intRow = 2 To intRecordCount + 1
                For intCol = 1 To UBound(aRows, 1) + 1
                    .Cells(intRow, intCol).Value = aRows(intCol - 1, intRow - 2)
                Next
            Next
       End With
ELSE
      'Build up a massive string of Data + TAB + DATA + TAB + EOL for all data rows.
        MText = ""
        For intRow = 2 To EXPORTROWS + 1
            RowText = ""
            For intCol = 1 To UBound(aRows, 1) + 1
                RowText = RowText & aRows(intCol - 1, intRow - 2) & CHR(9)
            NEXT
            MText =  MText & RowText & CHR(13)
        NEXT

        ''''put the string into the windows clipboard.
        DIM oSHELL, objHTM
        set oShell = CreateObject("WScript.Shell")
        Set objHTM = CreateObject("htmlfile")

        objHTM.ParentWindow.ClipboardData.SetData   "text", MText
        'paste it into Excel.
        objExcel.Range("A2").SELECT
        objExcel.ActiveSheet.Paste
END IF
       objExcel.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
       objExcel.Visible = True
       TIMEEND = Timer
       Erase aColCaptions
       Set objExcel = Nothing
    TimeUsed = (TimeEnd - TimeStart)
    MSGBOX "Grid exported to Excel, formatted, in: " & TIMEUSED & " seconds. "
End Sub

Sub ExportRSToExcel(objRS, SheetName)
    Dim intRow, intCol, intRecordCount
    Dim aRows

    On Error Resume Next
       'Move to the first record
       objRS.MoveFirst

       'Read all of the records into an array
       aRows = objRS.GetRows()

       'Get the number of fields and records
       intRecordCount = UBound(aRows, 2) + 1
       ExportRows =  intRecordCount - 1
       'Create reference variable for the spreadsheet. If Excel isn't found exit sub
       If Not CreateExcelObject Then Exit Sub
       if intRecordCount > BigReportSize THEN MSGBOX "Wait one, creating spreadsheet for " & intRecordCount & " rows."
       TIMESTART = Timer
       objExcel.Visible = FALSE
       objExcel.Workbooks.Add

       'Ensure that Excel remains visible if we switch to the Active Sheet
       SetExcelActiveSheet(objExcel)
       'Set the SpreedSheet name, if specified
       If SheetName <> "" Then
          'Sheet name can be no more than 31 characters
          objExcel.Sheets(1).Name = LEFT(TRIM("" & SheetName),31)
       End If

       'Place the names of the fields in the column headers
      '''' RJ Samp
       dim strName
      DIM J, strALIAS
       For intCol = 1 To UBound(aRows, 1) + 1
           objExcel.Columns(intCol).VerticalAlignment = -4160 'Align Top
           objExcel.Columns(intCol).NumberFormat = GetDBFormatType(objRS.Fields.Item(intCol - 1).Type)
           With objExcel.Cells(1, intCol)
                strName = Application.Translator.Localize(objRS.Fields(intCol - 1).Name)
                FOR J = 2 TO 20
                    strALIAS = "A" & cSTR(J) & "_"
                    strName = Replace(strName,strALIAS, "")
                NEXT
                     strName = Replace(strName,"_", " ")
                     .Value = objExcel.PROPER(strName)
                With .Font
                     .Name = "Arial"  'DNL
                     .Bold = True
                     .Size = 9
                End With
           End With
       Next

       'Add data
       IF EXPORTROWS > MaxExcelROWS - 2 THEN EXPORTROWS = MaxExcelROWS - 2
if intRecordCount <= BigReportSize THEN

       'Add records
       With objExcel
            For intRow = 2 To intRecordCount + 1
                For intCol = 1 To UBound(aRows, 1) + 1
                    .Cells(intRow, intCol).Value = aRows(intCol - 1, intRow - 2)
                Next
            Next
       End With
ELSE
      'Build up a massive string of Data + TAB + DATA + TAB + EOL for all data rows.
        MText = ""
        For intRow = 2 To EXPORTROWS + 1
            RowText = ""
            For intCol = 1 To UBound(aRows, 1) + 1
                RowText = RowText & aRows(intCol - 1, intRow - 2) & CHR(9)
            NEXT
            MText =  MText & RowText & CHR(13)
        NEXT

        ''''put the string into the windows clipboard.
        DIM oSHELL, objHTM
        set oShell = CreateObject("WScript.Shell")
        Set objHTM = CreateObject("htmlfile")

        objHTM.ParentWindow.ClipboardData.SetData   "text", MText
        'paste it into Excel.
        objExcel.Range("A2").SELECT
        objExcel.ActiveSheet.Paste
END IF

       objExcel.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
       objExcel.Visible = True
        TIMEEND = Timer
       Set objExcel = Nothing
    On Error Goto 0
    TimeUsed = (TimeEnd - TimeStart)
    MSGBOX "RecordSet exported to Excel in: " & TIMEUSED & " seconds. "
End Sub

'Create reference variable for the spreadsheet if Excel is found, if not display message.
Function CreateExcelObject
    Dim blnExcel

    blnExcel = True
    On Error Resume Next
       'Create reference variable for the spreadsheet
       Set objExcel = CreateObject("Excel.Application")  'DNL
       If Not IsObject(objExcel) Then
          MsgBox Application.Translator.Localize("Microsoft Excel cannot be found. ") & vbCrLf & vbCrLf & _
                 Application.Translator.Localize("Please insure Excel is installed prior to using this feature."), vbExclamation, "SalesLogix"
          blnExcel = False
       End If

       CreateExcelObject = blnExcel
End Function

Sub SetExcelActiveSheet(objExcel)
    Dim objTemp

    Set objTemp = objExcel
    If objExcel.Application.Version >= 8 Then
       Set objExcel = objExcel.ActiveSheet
    End If

    Set objTemp = Nothing
End Sub

Function GetArrayVisibleColumnNames(objGrid)
    Dim aColumns()
    Dim i, intColumn

    intColumn = 0
    'Get the number of visible columns on the grid
    ReDim aColumns(GetVisibleColumnsCount(objGrid))
    For i = 0 To objGrid.Columns.Count - 1
        'For each visible column add to array
        If objGrid.Columns.Item(i).Visible Then
           aColumns(intColumn) = objGrid.Columns.Item(i).FieldName
           intColumn = intColumn + 1
        End If
    Next

    GetArrayVisibleColumnNames = aColumns

    Erase aColumns
End Function

Function GetArrayVisibleColumnCaptions(objGrid)
    Dim aColumns()
    Dim intColumn
    Dim i

    intColumn = 0
    'Get the number of visible columns on the grid
    ReDim aColumns(GetVisibleColumnsCount(objGrid))
    For i = 0 To objGrid.Columns.Count - 1
        'For each visible column add to array
        If objGrid.Columns.Item(i).Visible Then
           aColumns(intColumn) = objGrid.Columns.Item(i).Caption
           intColumn = intColumn + 1
        End If
    Next
    GetArrayVisibleColumnCaptions = aColumns
End Function

Function GetVisibleColumnsCount(objGrid)
    Dim i, intCount

    'Loop through the Columns collection of the grid to get count of visible columns
    intCount = 0
    For i = 0 To objGrid.Columns.Count - 1
        If objGrid.Columns.Item(i).Visible Then
           intCount = intCount + 1
        End If
    Next

    GetVisibleColumnsCount = intCount - 1
End Function

Function GetFormatType(strFormatType)
    Select Case strFormatType
           Case 2 'Integer
                GetFormatType = "#,##0"  'DNL
           Case 5 'Currency'
                GetFormatType = FormatCurrencyString
           Case 10 ' Pos Integer
                GetFormatType = "#,##0"  'DNL
           Case Else
                GetFormatType = ""
    End select
End Function

Function GetDBFormatType(strFormatType)
    Select Case strFormatType
           Case 3 'adInteger
                GetDBFormatType = "#,##0"  'DNL
           Case 4 'adSingle
                GetDBFormatType = FormatCurrencyString
           Case 5 'adDouble
                GetDBFormatType = FormatCurrencyString
           Case 6 'adCurrency'
                GetDBFormatType = FormatCurrencyString
           Case 11 'adBoolean
                GetDBFormatType = "#,##0"  'DNL
           Case 131 'adNumeric
                GetDBFormatType = "#,##0"  'DNL
           Case Else
                GetDBFormatType = ""
    End select
End Function

Function FormatCurrencyString
    If Not blnCurrencySymbol Then
       FormatCurrencyString = "#,##0.00"  'DNL
    Else
       Select Case Application.Translator.CurrencyFormat
              Case 0
                   FormatCurrencyString = Application.Translator.CurrencyString & "#,##0.00"  'DNL
              Case 3
                   FormatCurrencyString = "#,##0.00 " + Application.Translator.CurrencyString  'DNL
              Case Else
                   FormatCurrencyString = Application.Translator.CurrencyString + " #,##0.00"  'DNL
       End Select
    End If
End Function

'Looks for duplicate records based on specified Fields, if found enters an empty string as the new value
'Paramaters: objRS - Recordset object
'            aFieldNames - Array of Fields to be searched
Function RemoveDuplicateValue(objRS, aFieldNames)
    Dim strValue, Field
    Dim i

    With objRS
         .MoveFirst
         For Each Field In aFieldNames
             For i = 0 To .RecordCount - 1
                 If .Fields.Item(Field).Value = strValue Then
                    .Fields.Item(Field).Value = ""
                 End If
                 strValue = .Fields.Item(Field).OriginalValue
                 .MoveNext
             Next
             .MoveFirst
         Next
    End With
End Function

'Loops through RS for the specified value, if found replaces old value with the specified new value
'Paramaters: objRS - Recordset object
'            aFieldNames - Array of Fields to be searched
'            strValue - Value to be searched and replaced if found
'            strNewValue - New value of strValue if found
Function RecordsetReplaceValues(objRS, aFieldNames, strValue, strNewValue)
    Dim Field
    Dim i

    With objRS
         .MoveFirst
         For i = 0 To .RecordCount - 1
             For Each Field In aFieldNames
                 If Not IsNull(.Fields.Item(Field).Value) Then
                    .Fields.Item(Field).Value = Replace(.Fields.Item(Field).Value, strValue, strNewValue)
                 End If
             Next
             .MoveNext
         Next
    End With

    Set RecordsetReplaceValues = objRS
End Function

Sub DisplayCurrencySymbol(blnValue)
    blnCurrencySymbol = blnValue
End Sub

Function GetFormatType(strFormatType)
  Select Case strFormatType
    Case 2 'Integer
       GetFormatType = "#,##0" 'DNL
    Case 5 'Currency'
       GetFormatType = FormatCurrencyString
    Case 10 ' Pos Integer
       GetFormatType = "#,##0" 'DNL
    Case Else
      GetFormatType = ""
  End select
End Function

Sub OpenFile(strFile)
  Dim objShell

  Set objShell = CreateObject("Shell.Application")
  objShell.ShellExecute strFile, "", "", "open", 1
  Set objShell = Nothing
End Sub