mod_export.bas

Billing Internet Cafe

Attribute VB_Name = "Mod_export"

Option Explicit

Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" ( _
                ByVal hWnd As Long, _
                ByVal lpString As String) As Long

Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" ( _
                ByVal hWnd As Long, _
                ByVal lpString As String, _
                ByVal hData As Long) As Long

Private Declare Function RemoveProp Lib "user32.dll" Alias "RemovePropA" ( _
                ByVal hWnd As Long, _
                ByVal lpString As String) As Long

Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
                ByVal lpPrevWndFunc As Long, _
                ByVal hWnd As Long, _
                ByVal msg As Long, _
                ByVal wParam As Long, _
                ByVal lParam As Long) As Long

Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
                ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowRect Lib "user32" ( _
                ByVal hWnd As Long, _
                lpRect As RECT) As Long
                
Private Declare Function GetParent Lib "user32" ( _
                ByVal hWnd As Long) As Long

Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
                ByVal hWnd As Long, _
                ByVal msg As Long, _
                wParam As Any, _
                lParam As Any) As Long

Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const CB_GETDROPPEDSTATE = &H157

' string used to identify which record to open in adoClsCustomer
Public idnum As Integer
' string used to identify which record to open in adoClsPurchases
Public ponum As Integer




Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
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)
  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
        
        objExcelDel.DisplayAlerts = False
Set objWorksheetDel = objExcelDel.ActiveSheet
 
  With objWorksheetDel
       
   
    For lRow = 1 To rowOffset
           .PageSetup.CenterHeader = TempStr(lRow - 1)
    Next lRow
    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
   If Val(WorkBkGridColorIndex) > 0 Then
    With objWorkbookDel.Styles("Normal").Borders(xlLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    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
        If Val(ColumnHeaderBackColorIndex) > 0 Then
            .Interior.ColorIndex = ColumnHeaderBackColorIndex
            Else
            .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
        If Val(ColumnHeaderFontColorIndex) > 0 Then
            .Font.ColorIndex = ColumnHeaderFontColorIndex
            Else
            .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
        '******************************************
   'Inserts company logo or picture in Cell A1
   ' The logo has to be the right size for the effect you are looking for. I suggest taking your current logo and editing it in photoshop
   ' In Office 2007 you will have to specify the exact cell you want but for previous versions you do not have to.
   If Len(CoLogoPicLocation) > 0 Then
          Set PicObject = objWorksheetDel.Pictures.Insert(CoLogoPicLocation)
           ' PicObject.Pictures.Insert (CoLogoPicLocation)
            End If
   '******************************************
    '''''''''''''''''''''''''''''''''''''''''
    ' Fit Clogo picture to col headers does not work yet
   ' If AutoFitLogoPic = True Then
   ' Dim ColCount As Integer
   ' ColCount = FG.Cols - 1
   ' Dim CC As Integer
   ' Dim PicWidth As Double
   ' Do Until CC = ColCount
   '     PicWidth = .Columns(1, CC).ColumnWidth
   '     CC = CC + 1
   '     Loop
   ' PicObject.LockAspectRatio = msoFalse
   ' PicObject.Width = PicWidth
   ' PicObject.ScaleWidth PicWidth, msoFalse, msoScaleFromTopLeft
   ' End If
  
    '.Shapes.Range.Width = PicWidth
    
    
    ''''''''''''''''''''''''''''''''''''''''''
    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