VB EXPORTANDO PARA O EXCEL FORMATACAO DE CELULAS

  
Option Explicit

[ô]Constantes
[ô]----------------------------------------------------------------------------------------
    Const EXCEL5 = 39

[ô]Objetos
[ô]----------------------------------------------------------------------------------------
    Private objExcel         As Object [ô]Excel.Application
    Private objWorkbook      As Object [ô]Excel.Workbook
    Private objSheet         As Object [ô]Excel.Worksheet

[ô]Tipos / Enums
[ô]----------------------------------------------------------------------------------------
    Public Type tPageSetup
        psOrientation           As ePrinterOrientation
        psPaperSize             As ePrintPapers
        psLeftMargin            As Single
        psRightMargin           As Single
        psTopMargin             As Single
        psBottomMargin          As Single
        psHeaderMargin          As Single
        psFooterMargin          As Single
        psCenterHorizontally    As Boolean
        psCenterVertically      As Boolean
        psZoom                  As Integer
    End Type
    
    Public Enum eAlign
        aCenter = -4108
        aLeft = -4131
        aRight = -4152
    End Enum

    Public Enum ePrinterOrientation
        oPortrait = 1
        oLandscape = 2
    End Enum
    
    Public Enum ePrintPapers
        pPaperLetter = 1
        pPaperLegal = 5
        pPaperExecutive = 7
        pPaperA4 = 9
    End Enum

Public Function OpenExcel(ByVal pstrFileName As String, ByVal pintCase As Integer, _
                          ByVal pintItem As Integer, ByVal pintContador As Integer) As Integer
    
    On Error GoTo TraTaErro

    OpenExcel = vbCancel
    
    If pintContador = 1 Then
        Set objExcel = CreateObject([Ô]Excel.Application[Ô])
        objExcel.Visible = False
        objExcel.ScreenUpdating = False
    End If
    
    Select Case pintCase
        Case 0
        
            If pstrFileName <> [Ô][Ô] Then
                objExcel.Workbooks.Open pstrFileName, True, False
            Else
                [ô]Adiciona uma pasta apenas
                objExcel.SheetsInNewWorkbook = 1
                Set objWorkbook = objExcel.Workbooks.Add
                Set objSheet = objWorkbook.Worksheets(1)
                objSheet.Name = [Ô]Dados[Ô]
            End If
        
        Case 1
            [ô]*** Número de planilhas a ser adicionada
            If pintContador = 1 Then
                objExcel.SheetsInNewWorkbook = 16
                Set objWorkbook = objExcel.Workbooks.Add
            End If
            
            Set objSheet = objWorkbook.Worksheets(pintContador)
            objSheet.Name = [Ô]Item [Ô] & pintItem
            
    End Select
    
    OpenExcel = vbOK
    
    Exit Function
    
TraTaErro:
        
    MsgBox [Ô]Erro nº [Ô] & Err.Number & [Ô] - [Ô] & Err.Description, vbExclamation, [Ô]Atenção[Ô]
    
End Function

Public Function RemovePlan() As Integer
    
    On Error GoTo TraTaErro
    
    objExcel.Quit
    Set objExcel = Nothing
    
    Exit Function
    
TraTaErro:
    MsgBox [Ô]Erro nº [Ô] & Err.Number & [Ô] - [Ô] & Err.Description, vbExclamation, [Ô]Atenção[Ô]

End Function

Public Function ShowPlan() As Integer
    
    On Error GoTo TraTaErro
    
    ShowPlan = vbCancel
    
    objExcel.ScreenUpdating = True
    objExcel.Visible = True
    Set objExcel = Nothing
    
    ShowPlan = vbOK
    
    Exit Function
    
TraTaErro:
    MsgBox [Ô]Erro nº [Ô] & Err.Number & [Ô] - [Ô] & Err.Description, vbExclamation, [Ô]Atenção[Ô]
    
End Function

Public Function ActivePlan(ByVal pstrNamePlan As String) As Integer
    
    On Error GoTo TraTaErro
    
    If pstrNamePlan <> [Ô][Ô] Then
        objExcel.Worksheets(pstrNamePlan).Activate
    Else
        objExcel.Worksheets(1).Activate
    End If
    
    Exit Function
    
TraTaErro:
    MsgBox [Ô]Erro nº [Ô] & Err.Number & [Ô] - [Ô] & Err.Description, vbExclamation, [Ô]Atenção[Ô]
    
End Function
        
Public Function PutValue(ByVal pintRow As Integer, _
                         ByVal pintCol As Integer, _
                Optional ByVal pstrValue As String = [Ô] [Ô], _
                Optional ByVal pobjFonte As Object, _
                Optional ByVal pblnAlignNumber As Boolean, _
                Optional ByVal pAlign As eAlign = aLeft, _
                Optional ByVal pblnPageBreak As Boolean = False, _
                Optional ByVal pstrItem As String, _
                Optional ByVal pblnTitulo As Boolean) As Boolean
    
    On Error GoTo TraTaErro
    
    [ô]*** SELECIONA A ABA PARA INCLUIR O VALOR ***************
    objWorkbook.Sheets(pstrItem).Select
    [ô]********************************************************
    
    [ô]*** MESCLA AS CELULAS **********************************
    If pintRow = 1 Then
        objExcel.ActiveSheet.Range([Ô]A1[Ô], [Ô]E1[Ô]).Columns.Merge
    End If
    [ô]********************************************************
    
    With objExcel.ActiveSheet.Cells(pintRow, pintCol)
        .Value = pstrValue
        .VerticalAlignment = -4108
        .HorizontalAlignment = pAlign
        
        If pblnTitulo = True Then
            .Interior.Color = vbBlue
            .Font.Color = vbWhite
        End If
        
        With .Font
            If .Bold <> pobjFonte.Bold Then .Bold = pobjFonte.Bold
            If .Italic <> pobjFonte.Italic Then .Italic = pobjFonte.Italic
            If .Name <> pobjFonte.Name Then .Name = pobjFonte.Name
            If .Size <> pobjFonte.Size Then .Size = pobjFonte.Size
            If .Strikethrough <> pobjFonte.Strikethrough Then .Strikethrough = pobjFonte.Strikethrough
            If .Underline <> pobjFonte.Underline Then .Underline = pobjFonte.Underline
        End With
        If pblnAlignNumber Then
            .NumberFormat = [Ô]General[Ô]
            .HorizontalAlignment = -4152
        End If
        Select Case pblnPageBreak
            Case True
                Call objExcel.ActiveSheet.HPageBreaks.Add(objExcel.ActiveSheet.Cells(pintRow, pintCol))
        End Select
    End With
    
    PutValue = True
    
    Exit Function
    
TraTaErro:
    MsgBox [Ô]Erro nº [Ô] & Err.Number & [Ô] - [Ô] & Err.Description, vbExclamation, [Ô]Atenção[Ô]
    
End Function

Public Function SaveExcel(ByVal pstrFileName As String) As Boolean
    
    On Error GoTo TraTaErro
    Dim strTempDir As String
    
    [ô] Salva a pasta no formato do Excel 5
    [ô]------------------------------------------------------------------------------------------
    Select Case True
        Case Dir(pstrFileName, vbArchive) <> [Ô][Ô]
            Kill pstrFileName
    End Select

    objWorkbook.SaveAs pstrFileName, EXCEL5

    SaveExcel = True
        
    Exit Function

TraTaErro:
    MsgBox [Ô]Erro nº [Ô] & Err.Number & [Ô] - [Ô] & Err.Description, vbExclamation, [Ô]Atenção[Ô]

End Function

Public Function SheetPageSetup(ByRef pobjPageSetup As tPageSetup) As Boolean
    With objSheet.PageSetup
        .PrintArea = [Ô][Ô]
        .LeftMargin = objExcel.CentimetersToPoints(pobjPageSetup.psLeftMargin)      [ô](0.5)
        .RightMargin = objExcel.CentimetersToPoints(pobjPageSetup.psRightMargin)    [ô](0.5)
        .TopMargin = objExcel.CentimetersToPoints(pobjPageSetup.psTopMargin)        [ô](1)
        .BottomMargin = objExcel.CentimetersToPoints(pobjPageSetup.psBottomMargin)  [ô](0)
        .HeaderMargin = objExcel.CentimetersToPoints(pobjPageSetup.psHeaderMargin)  [ô](0)
        .FooterMargin = objExcel.CentimetersToPoints(pobjPageSetup.psFooterMargin)  [ô](0)
        .CenterHorizontally = pobjPageSetup.psCenterHorizontally                    [ô]True
        .CenterVertically = pobjPageSetup.psCenterVertically                        [ô]True
        .Orientation = pobjPageSetup.psOrientation                                  [ô]xlLandscape
        [ô].PaperSize = pobjPageSetup.psPaperSize                                     [ô]xlPaperLetter
        [ô].Zoom = pobjPageSetup.psZoom                                               [ô]90
    End With
    SheetPageSetup = True
End Function