MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access


3 participantes

    Criar Planilha(Plan1) no Excel atraves do access

    avatar
    adriano944
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 187
    Registrado : 10/02/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  adriano944 4/6/2010, 08:10

    Pessoal

    Gostaria da ajuda de voces para saber como faço para criar uma planilha no excel atravez do access... ou entao, como faço para apagar os registros de uma planilha no excel...

    como se estivesse usando aquele comando:
    Cells.Select
    Selection.Delete Shift:=xlUp

    porem nao sei como fazer o comando acima pelo access..

    obrigado!
    vieirasoft
    vieirasoft
    Developer
    Developer


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7304
    Registrado : 11/05/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  vieirasoft 4/6/2010, 08:33

    Caro colega

    Tenho um módulo que ajuda a fazer isso. Talvez a primeira parte do problema esteja resolvida. TEnho também um exemplo de criar excel a partir de uma consulta em access, só que terei de procurar pois não sei aonde o meti. se encontrar aviso.

    Para já teste o módulo e veja se ajuda...guarde como Módulo de classe e com o nome de FicheiroExcel.

    Bom trabalho


    Option Compare Database


    'Class file for writing Microsoft Excel BIFF 2.1 files.

    'This class is intended for users who do not want to use the huge
    'Jet or ADO providers if they only want to export their data to
    'an Excel compatible file.

    'Newer versions of Excel use the OLE Structure Storage methods
    'which are quite complicated.

    'Paul Squires, November 10, 2001
    'rambo2000@canada.com

    'Added default-cellformats: Dieter Hauk January 8, 2001 dieter.hauk@epost.de
    'Added default row height: Matthew Brewster November 9, 2001

    'the memory copy API is used in the MKI$ function which converts an integer
    'value to a 2-byte string value to write to the file. (used by the Horizontal
    'Page Break function).
    Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)


    'enum to handle the various types of values that can be written
    'to the excel file.
    Public Enum ValueTypes
    xlsinteger = 0
    xlsnumber = 1
    xlsText = 2
    End Enum

    'enum to hold cell alignment
    Public Enum CellAlignment
    xlsGeneralAlign = 0
    xlsLeftAlign = 1
    xlsCentreAlign = 2
    xlsrightAlign = 3
    xlsFillCell = 4
    xlsLeftBorder = 8
    xlsRightBorder = 16
    xlsTopBorder = 32
    xlsBottomBorder = 64
    xlsShaded = 128
    End Enum

    'enum to handle selecting the font for the cell
    Public Enum CellFont
    'used by rgbAttr2
    'bits 0-5 handle the *picture* formatting, not bold/underline etc...
    'bits 6-7 handle the font number
    xlsFont0 = 0
    xlsFont1 = 64
    xlsFont2 = 128
    xlsFont3 = 192
    End Enum

    Public Enum CellHiddenLocked
    'used by rgbAttr1
    'bits 0-5 must be zero
    'bit 6 locked/unlocked
    'bit 7 hidden/not hidden
    xlsNormal = 0
    xlsLocked = 64
    xlsHidden = 128
    End Enum


    'set up variables to hold the spreadsheet's layout
    Public Enum MarginTypes
    xlsLeftMargin = 38
    xlsRightMargin = 39
    xlsTopMargin = 40
    xlsBottomMargin = 41
    End Enum


    Public Enum FontFormatting
    'add these enums together. For example: xlsBold + xlsUnderline
    xlsNoFormat = 0
    xlsBold = 1
    xlsItalic = 2
    xlsUnderline = 4
    xlsStrikeout = 8
    End Enum

    Private Type FONT_RECORD
    opcode As Integer '49
    length As Integer '5+len(fontname)
    FontHeight As Integer

    'bit0 bold, bit1 italic, bit2 underline, bit3 strikeout, bit4-7 reserved
    FontAttributes1 As Byte

    FontAttributes2 As Byte 'reserved - always 0

    FontNameLength As Byte
    End Type


    Private Type PASSWORD_RECORD
    opcode As Integer '47
    length As Integer 'len(password)
    End Type


    Private Type HEADER_FOOTER_RECORD
    opcode As Integer '20 Header, 21 Footer
    length As Integer '1+len(text)
    TextLength As Byte
    End Type


    Private Type PROTECT_SPREADSHEET_RECORD
    opcode As Integer '18
    length As Integer '2
    Protect As Integer
    End Type

    Private Type FORMAT_COUNT_RECORD
    opcode As Integer '1f
    length As Integer '2
    Count As Integer
    End Type

    Private Type FORMAT_RECORD
    opcode As Integer '1e
    length As Integer '1+len(format)
    FormatLenght As Byte 'len(format)
    End Type '+ followed by the Format-Picture



    Private Type COLWIDTH_RECORD
    opcode As Integer '36
    length As Integer '4
    col1 As Byte 'first column
    col2 As Byte 'last column
    ColumnWidth As Integer 'at 1/256th of a character
    End Type

    'Beginning Of File record
    Private Type BEG_FILE_RECORD
    opcode As Integer
    length As Integer
    version As Integer
    ftype As Integer
    End Type

    'End Of File record
    Private Type END_FILE_RECORD
    opcode As Integer
    length As Integer
    End Type

    'true/false to print gridlines
    Private Type PRINT_GRIDLINES_RECORD
    opcode As Integer
    length As Integer
    PrintFlag As Integer
    End Type

    'Integer record
    Private Type tInteger
    opcode As Integer
    length As Integer
    Row As Integer 'unsigned integer
    col As Integer

    'rgbAttr1 handles whether cell is hidden and/or locked
    rgbAttr1 As Byte

    'rgbAttr2 handles the Font# and Formatting assigned to this cell
    rgbAttr2 As Byte

    'rgbAttr3 handles the Cell Alignment/borders/shading
    rgbAttr3 As Byte

    intValue As Integer 'the actual integer value
    End Type

    'Number record
    Private Type tNumber
    opcode As Integer
    length As Integer
    Row As Integer
    col As Integer
    rgbAttr1 As Byte
    rgbAttr2 As Byte
    rgbAttr3 As Byte
    NumberValue As Double '8 Bytes
    End Type

    'Label (Text) record
    Private Type tText
    opcode As Integer
    length As Integer
    Row As Integer
    col As Integer
    rgbAttr1 As Byte
    rgbAttr2 As Byte
    rgbAttr3 As Byte
    TextLength As Byte
    End Type

    Private Type MARGIN_RECORD_LAYOUT
    opcode As Integer
    length As Integer
    MarginValue As Double '8 bytes
    End Type

    Private Type HPAGE_BREAK_RECORD
    opcode As Integer
    length As Integer
    NumPageBreaks As Integer
    End Type

    Private Type DEF_ROWHEIGHT_RECORD
    opcode As Integer
    length As Integer
    RowHeight As Integer
    End Type

    Private Type ROW_HEIGHT_RECORD
    opcode As Integer '08
    length As Integer 'should always be 16 bytes
    RowNumber As Integer
    FirstColumn As Integer
    LastColumn As Integer
    RowHeight As Integer 'written to file as 1/20ths of a point
    internal As Integer
    DefaultAttributes As Byte 'set to zero for no default attributes
    FileOffset As Integer
    rgbAttr1 As Byte
    rgbAttr2 As Byte
    rgbAttr3 As Byte
    End Type

    Private FileNumber As Integer
    Private BEG_FILE_MARKER As BEG_FILE_RECORD
    Private END_FILE_MARKER As END_FILE_RECORD
    Private HORIZ_PAGE_BREAK As HPAGE_BREAK_RECORD

    'create an array that will hold the rows where a horizontal page
    'break will be inserted just before.
    Private HorizPageBreakRows() As Integer
    Private NumHorizPageBreaks As Integer




    Public Function CreateFile(ByVal FileName As String) As Integer

    On Error GoTo Write_Error

    If Dir$(FileName) > "" Then
    Kill FileName
    End If

    FileNumber = FreeFile
    Open FileName For Binary As #FileNumber
    Put #FileNumber, , BEG_FILE_MARKER 'must always be written first

    Call WriteDefaultFormats

    'create the Horizontal Page Break array
    ReDim HorizPageBreakRows(0)
    NumHorizPageBreaks = 0

    OpenFile = 0 'return with no error

    Exit Function

    Write_Error:
    OpenFile = Err.Number
    Exit Function

    End Function

    Public Function CloseFile() As Integer

    On Error GoTo Write_Error

    If FileNumber = 0 Then Exit Function


    'write the horizontal page breaks if necessary
    If NumHorizPageBreaks > 0 Then
    'the Horizontal Page Break array must be in sorted order.
    'Use a simple Bubble sort because the size of this array would
    'be pretty small most of the time. A QuickSort would probably
    'be overkill.
    Dim lLoop1 As Long
    Dim lLoop2 As Long
    Dim lTemp As Long
    For lLoop1 = UBound(HorizPageBreakRows) To LBound(HorizPageBreakRows) Step -1
    For lLoop2 = LBound(HorizPageBreakRows) + 1 To lLoop1
    If HorizPageBreakRows(lLoop2 - 1) > HorizPageBreakRows(lLoop2) Then
    lTemp = HorizPageBreakRows(lLoop2 - 1)
    HorizPageBreakRows(lLoop2 - 1) = HorizPageBreakRows(lLoop2)
    HorizPageBreakRows(lLoop2) = lTemp
    End If
    Next lLoop2
    Next lLoop1

    'write the Horizontal Page Break Record
    With HORIZ_PAGE_BREAK
    .opcode = 27
    .length = 2 + (NumHorizPageBreaks * 2)
    .NumPageBreaks = NumHorizPageBreaks
    End With
    Put #FileNumber, , HORIZ_PAGE_BREAK

    'now write the actual page break values
    'the MKI$ function is standard in other versions of BASIC but
    'VisualBasic does not have it. A KnowledgeBase article explains
    'how to recreate it (albeit using 16-bit API, I switched it
    'to 32-bit).
    For x% = 1 To UBound(HorizPageBreakRows)
    Put #FileNumber, , MKI$(HorizPageBreakRows(x%))
    Next
    End If

    Put #FileNumber, , END_FILE_MARKER
    Close #FileNumber

    CloseFile = 0 'return with no error code

    Exit Function

    Write_Error:
    CloseFile = Err.Number
    Exit Function

    End Function


    Private Sub Class_Initialize()

    'Set up default values for records
    'These should be the values that are the same for every record of these types

    With BEG_FILE_MARKER 'beginning of file
    .opcode = 9
    .length = 4
    .version = 2
    .ftype = 10
    End With

    With END_FILE_MARKER 'end of file marker
    .opcode = 10
    End With


    End Sub


    Public Function InsertHorizPageBreak(lrow As Long) As Integer

    On Error GoTo Page_Break_Error

    'the row and column values are written to the excel file as
    'unsigned integers. Therefore, must convert the longs to integer.
    If lrow > 32767 Then
    Row% = CInt(lrow - 65536)
    Else
    Row% = CInt(lrow) - 1 'rows/cols in Excel binary file are zero based
    End If

    NumHorizPageBreaks = NumHorizPageBreaks + 1
    ReDim Preserve HorizPageBreakRows(NumHorizPageBreaks)

    HorizPageBreakRows(NumHorizPageBreaks) = Row%

    Exit Function


    Page_Break_Error:
    InsertHorizPageBreak = Err.Number
    Exit Function


    End Function



    Public Function WriteValue(ValueType As ValueTypes, CellFontUsed As CellFont, Alignment As CellAlignment, HiddenLocked As CellHiddenLocked, lrow As Long, lcol As Long, value As Variant, Optional CellFormat As Long = 0) As Integer

    On Error GoTo Write_Error

    'the row and column values are written to the excel file as
    'unsigned integers. Therefore, must convert the longs to integer.

    If lrow > 32767 Then
    Row% = CInt(lrow - 65536)
    Else
    Row% = CInt(lrow) - 1 'rows/cols in Excel binary file are zero based
    End If

    If lcol > 32767 Then
    col% = CInt(lcol - 65536)
    Else
    col% = CInt(lcol) - 1 'rows/cols in Excel binary file are zero based
    End If


    Select Case ValueType
    Case ValueTypes.xlsinteger
    Dim INTEGER_RECORD As tInteger
    With INTEGER_RECORD
    .opcode = 2
    .length = 9
    .Row = Row%
    .col = col%
    .rgbAttr1 = CByte(HiddenLocked)
    .rgbAttr2 = CByte(CellFontUsed + CellFormat)
    .rgbAttr3 = CByte(Alignment)
    .intValue = CInt(value)
    End With
    Put #FileNumber, , INTEGER_RECORD


    Case ValueTypes.xlsnumber
    Dim NUMBER_RECORD As tNumber
    With NUMBER_RECORD
    .opcode = 3
    .length = 15
    .Row = Row%
    .col = col%
    .rgbAttr1 = CByte(HiddenLocked)
    .rgbAttr2 = CByte(CellFontUsed + CellFormat)
    .rgbAttr3 = CByte(Alignment)
    .NumberValue = CDbl(value)
    End With
    Put #FileNumber, , NUMBER_RECORD


    Case ValueTypes.xlsText
    Dim b As Byte
    st$ = CStr(value)
    l% = Len(st$)

    Dim TEXT_RECORD As tText
    With TEXT_RECORD
    .opcode = 4
    .length = 10
    'Length of the text portion of the record
    .TextLength = l%

    'Total length of the record
    .length = 8 + l

    .Row = Row%
    .col = col%

    .rgbAttr1 = CByte(HiddenLocked)
    .rgbAttr2 = CByte(CellFontUsed + CellFormat)
    .rgbAttr3 = CByte(Alignment)

    'Put record header
    Put #FileNumber, , TEXT_RECORD

    'Then the actual string data
    For a = 1 To l%
    b = Asc(Mid$(st$, a, 1))
    Put #FileNumber, , b
    Next
    End With

    End Select

    WriteValue = 0 'return with no error

    Exit Function

    Write_Error:
    WriteValue = Err.Number
    Exit Function

    End Function


    Public Function SetMargin(Margin As MarginTypes, MarginValue As Double) As Integer

    On Error GoTo Write_Error

    'write the spreadsheet's layout information (in inches)
    Dim MarginRecord As MARGIN_RECORD_LAYOUT

    With MarginRecord
    .opcode = Margin
    .length = 8
    .MarginValue = MarginValue 'in inches
    End With
    Put #FileNumber, , MarginRecord

    SetMargin = 0

    Exit Function

    Write_Error:
    SetMargin = Err.Number
    Exit Function

    End Function


    Public Function SetColumnWidth(FirstColumn As Byte, LastColumn As Byte, WidthValue As Integer)

    On Error GoTo Write_Error

    Dim COLWIDTH As COLWIDTH_RECORD

    With COLWIDTH
    .opcode = 36
    .length = 4
    .col1 = FirstColumn - 1
    .col2 = LastColumn - 1
    .ColumnWidth = WidthValue * 256 'values are specified as 1/256 of a character
    End With
    Put #FileNumber, , COLWIDTH

    SetColumnWidth = 0

    Exit Function

    Write_Error:
    SetColumnWidth = Err.Number
    Exit Function

    End Function


    Public Function SetFont(FontName As String, FontHeight As Integer, FontFormat As FontFormatting) As Integer

    On Error GoTo Write_Error

    'you can set up to 4 fonts in the spreadsheet file. When writing a value such
    'as a Text or Number you can specify one of the 4 fonts (numbered 0 to 3)

    Dim FONTNAME_RECORD As FONT_RECORD

    l% = Len(FontName)

    With FONTNAME_RECORD
    .opcode = 49
    .length = 5 + l%
    .FontHeight = FontHeight * 20
    .FontAttributes1 = CByte(FontFormat) 'bold/underline etc...
    .FontAttributes2 = CByte(0) 'reserved-always zero!!
    .FontNameLength = CByte(Len(FontName))
    End With
    Put #FileNumber, , FONTNAME_RECORD

    'Then the actual font name data
    Dim b As Byte
    For a = 1 To l%
    b = Asc(Mid$(FontName, a, 1))
    Put #FileNumber, , b
    Next

    SetFont = 0

    Exit Function

    Write_Error:
    SetFont = Err.Number
    Exit Function


    End Function


    Public Function SetHeader(HeaderText As String) As Integer

    On Error GoTo Write_Error

    Dim HEADER_RECORD As HEADER_FOOTER_RECORD

    l% = Len(HeaderText)

    With HEADER_RECORD
    .opcode = 20
    .length = 1 + l%
    .TextLength = CByte(Len(HeaderText))
    End With
    Put #FileNumber, , HEADER_RECORD

    'Then the actual Header text
    Dim b As Byte
    For a = 1 To l%
    b = Asc(Mid$(HeaderText, a, 1))
    Put #FileNumber, , b
    Next

    SetHeader = 0

    Exit Function

    Write_Error:
    SetHeader = Err.Number
    Exit Function

    End Function



    Public Function SetFooter(FooterText As String) As Integer

    On Error GoTo Write_Error

    Dim FOOTER_RECORD As HEADER_FOOTER_RECORD

    l% = Len(FooterText)

    With FOOTER_RECORD
    .opcode = 21
    .length = 1 + l%
    .TextLength = CByte(Len(FooterText))
    End With
    Put #FileNumber, , FOOTER_RECORD

    'Then the actual Header text
    Dim b As Byte
    For a = 1 To l%
    b = Asc(Mid$(FooterText, a, 1))
    Put #FileNumber, , b
    Next

    SetFooter = 0

    Exit Function

    Write_Error:
    SetFooter = Err.Number
    Exit Function

    End Function



    Public Function SetFilePassword(PasswordText As String) As Integer

    On Error GoTo Write_Error

    Dim FILE_PASSWORD_RECORD As PASSWORD_RECORD

    l% = Len(PasswordText)

    With FILE_PASSWORD_RECORD
    .opcode = 47
    .length = l%
    End With
    Put #FileNumber, , FILE_PASSWORD_RECORD

    'Then the actual Password text
    Dim b As Byte
    For a = 1 To l%
    b = Asc(Mid$(PasswordText, a, 1))
    Put #FileNumber, , b
    Next

    SetFilePassword = 0

    Exit Function

    Write_Error:
    SetFilePassword = Err.Number
    Exit Function

    End Function




    Public Property Let PrintGridLines(ByVal newvalue As Boolean)

    On Error GoTo Write_Error

    Dim GRIDLINES_RECORD As PRINT_GRIDLINES_RECORD

    With GRIDLINES_RECORD
    .opcode = 43
    .length = 2
    If newvalue = True Then
    .PrintFlag = 1
    Else
    .PrintFlag = 0
    End If

    End With
    Put #FileNumber, , GRIDLINES_RECORD

    Exit Property

    Write_Error:
    Exit Property


    End Property




    Public Property Let ProtectSpreadsheet(ByVal newvalue As Boolean)

    On Error GoTo Write_Error

    Dim PROTECT_RECORD As PROTECT_SPREADSHEET_RECORD

    With PROTECT_RECORD
    .opcode = 18
    .length = 2
    If newvalue = True Then
    .Protect = 1
    Else
    .Protect = 0
    End If

    End With
    Put #FileNumber, , PROTECT_RECORD

    Exit Property

    Write_Error:
    Exit Property


    End Property


    Public Function WriteDefaultFormats() As Integer

    Dim cFORMAT_COUNT_RECORD As FORMAT_COUNT_RECORD
    Dim cFORMAT_RECORD As FORMAT_RECORD
    Dim lIndex As Long
    Dim aFormat(0 To 23) As String
    Dim l As Long
    Dim q As String
    q = Chr$(34)

    aFormat(0) = "General"
    aFormat(1) = "0"
    aFormat(2) = "0.00"
    aFormat(3) = "#,##0"
    aFormat(4) = "#,##0.00"
    aFormat(5) = "#,##0\ " & q & "$" & q & ";\-#,##0\ " & q & "$" & q
    aFormat(6) = "#,##0\ " & q & "$" & q & ";[Red]\-#,##0\ " & q & "$" & q
    aFormat(7) = "#,##0.00\ " & q & "$" & q & ";\-#,##0.00\ " & q & "$" & q
    aFormat(Cool = "#,##0.00\ " & q & "$" & q & ";[Red]\-#,##0.00\ " & q & "$" & q
    aFormat(9) = "0%"
    aFormat(10) = "0.00%"
    aFormat(11) = "0.00E+00"
    aFormat(12) = "dd/mm/yy"
    aFormat(13) = "dd/\ mmm\ yy"
    aFormat(14) = "dd/\ mmm"
    aFormat(15) = "mmm\ yy"
    aFormat(16) = "h:mm\ AM/PM"
    aFormat(17) = "h🇲🇲ss\ AM/PM"
    aFormat(18) = "hh:mm"
    aFormat(19) = "hh🇲🇲ss"
    aFormat(20) = "dd/mm/yy\ hh:mm"
    aFormat(21) = "##0.0E+0"
    aFormat(22) = "mm:ss"
    aFormat(23) = "@"

    With cFORMAT_COUNT_RECORD
    .opcode = &H1F
    .length = &H2
    .Count = CInt(UBound(aFormat))
    End With
    Put #FileNumber, , cFORMAT_COUNT_RECORD

    For lIndex = LBound(aFormat) To UBound(aFormat)
    l = Len(aFormat(lIndex))
    With cFORMAT_RECORD
    .opcode = &H1E
    .length = CInt(l + 1)
    .FormatLenght = CInt(l)
    End With
    Put #FileNumber, , cFORMAT_RECORD

    'Then the actual format
    Dim b As Byte, a As Long
    For a = 1 To l
    b = Asc(Mid$(aFormat(lIndex), a, 1))
    Put #FileNumber, , b
    Next
    Next lIndex

    Exit Function

    End Function


    Function MKI$(x As Integer)
    'used for writing integer array values to the disk file
    temp$ = Space$(2)
    CopyMemory ByVal temp$, x%, 2
    MKI$ = temp$
    End Function


    Public Function SetDefaultRowHeight(HeightValue As Integer)

    On Error GoTo Write_Error

    'Height is defined in units of 1/20th of a point. Therefore, a 10-point font
    'would be 200 (i.e. 200/20 = 10). This function takes a HeightValue such as
    '14 point and converts it the correct size before writing it to the file.

    Dim DEFHEIGHT As DEF_ROWHEIGHT_RECORD

    With DEFHEIGHT
    .opcode = 37
    .length = 2
    .RowHeight = HeightValue * 20 'convert points to 1/20ths of point
    End With
    Put #FileNumber, , DEFHEIGHT

    SetDefaultRowHeight = 0

    Exit Function

    Write_Error:
    SetDefaultRowHeight = Err.Number
    Exit Function

    End Function


    Public Function SetRowHeight(lrow As Long, HeightValue As Integer)

    On Error GoTo Write_Error

    'the row and column values are written to the excel file as
    'unsigned integers. Therefore, must convert the longs to integer.

    If lrow > 32767 Then
    Row% = CInt(lrow - 65536)
    Else
    Row% = CInt(lrow) - 1 'rows/cols in Excel binary file are zero based
    End If


    'Height is defined in units of 1/20th of a point. Therefore, a 10-point font
    'would be 200 (i.e. 200/20 = 10). This function takes a HeightValue such as
    '14 point and converts it the correct size before writing it to the file.

    Dim ROWHEIGHTREC As ROW_HEIGHT_RECORD

    With ROWHEIGHTREC
    .opcode = 8
    .length = 16
    .RowNumber = Row%
    .FirstColumn = 0
    .LastColumn = 256
    .RowHeight = HeightValue * 20 'convert points to 1/20ths of point
    .internal = 0
    .DefaultAttributes = 0
    .FileOffset = 0
    .rgbAttr1 = 0
    .rgbAttr2 = 0
    .rgbAttr3 = 0
    End With
    Put #FileNumber, , ROWHEIGHTREC

    SetRowHeight = 0

    Exit Function

    Write_Error:
    SetRowHeight = Err.Number
    Exit Function

    End Function
    vieirasoft
    vieirasoft
    Developer
    Developer


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7304
    Registrado : 11/05/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  vieirasoft 4/6/2010, 08:40

    TEnho sempre que esquecer alguma coisa....Mil perdões

    Após copiar e gravar o módulo teste no form com um botão de comando:

    Private Sub Comando1_Click()
    Dim meuFicheiroExcel As New FicheiroExcel

    With meuFicheiroExcel
    'Create the new spreadsheet
    FileName$ = CurrentProject.Path & "\vbtest.xls" 'create spreadsheet in the current directory
    .CreateFile FileName$

    'set a Password for the file. If set, the rest of the spreadsheet will
    'be encrypted. If a password is used it must immediately follow the
    'CreateFile method.
    'This is different then protecting the spreadsheet (see below).
    'NOTE: For some reason this function does not work. Excel will
    'recognize that the file is password protected, but entering the password
    'will not work. Also, the file is not encrypted. Therefore, do not use
    'this function until I can figure out why it doesn't work. There is not
    'much documentation on this function available.
    '.SetFilePassword "PAUL"



    'specify whether to print the gridlines or not
    'this should come before the setting of fonts and margins
    .PrintGridLines = False


    'it is a good idea to set margins, fonts and column widths
    'prior to writing any text/numerics to the spreadsheet. These
    'should come before setting the fonts.

    .SetMargin xlsTopMargin, 1.5 'set to 1.5 inches
    .SetMargin xlsLeftMargin, 1.5
    .SetMargin xlsRightMargin, 1.5
    .SetMargin xlsBottomMargin, 1.5


    'to insert a Horizontal Page Break you need to specify the row just
    'after where you want the page break to occur. You can insert as many
    'page breaks as you wish (in any order).
    .InsertHorizPageBreak 10
    .InsertHorizPageBreak 20

    'set a default row height for the entire spreadsheet (1/20th of a point)
    .SetDefaultRowHeight 14


    'Up to 4 fonts can be specified for the spreadsheet. This is a
    'limitation of the Excel 2.1 format. For each value written to the
    'spreadsheet you can specify which font to use.

    .SetFont "Arial", 10, xlsNoFormat 'font0
    .SetFont "Arial", 10, xlsBold 'font1
    .SetFont "Arial", 10, xlsBold + xlsUnderline 'font2
    .SetFont "Courier", 16, xlsBold + xlsItalic 'font3


    'Column widths are specified in Excel as 1/256th of a character.
    .SetColumnWidth 1, 5, 18

    'Set special row heights for row 1 and 2
    .SetRowHeight 1, 30
    .SetRowHeight 2, 30


    'set any header or footer that you want to print on
    'every page. This text will be centered at the top and/or
    'bottom of each page. The font will always be the font that
    'is specified as font0, therefore you should only set the
    'header/footer after specifying the fonts through SetFont.
    .SetHeader "Creación de Fichero Excel"
    .SetFooter "Idea original en VB de Paul Squires "

    'write a normal left aligned string using font3 (Courier Italic)
    .WriteValue xlsText, xlsFont3, xlsLeftAlign, xlsNormal, 1, 1, "Informe Trimestral"
    .WriteValue xlsText, xlsFont1, xlsLeftAlign, xlsNormal, 2, 1, "Nombre de su Empresa"

    'write some data to the spreadsheet
    'Use the default format #3 "#,##0" (refer to the WriteDefaultFormats function)
    'The WriteDefaultFormats function is compliments of Dieter Hauk in Germany.
    .WriteValue xlsinteger, xlsFont0, xlsLeftAlign, xlsNormal, 6, 1, 2000, 3


    'write a cell with a shaded number with a bottom border
    .WriteValue xlsnumber, xlsFont1, xlsrightAlign + xlsBottomBorder + xlsShaded, xlsNormal, 7, 1, 12123.456, 4

    'write a normal left aligned string using font2 (bold & underline)
    .WriteValue xlsText, xlsFont2, xlsLeftAlign, xlsNormal, 8, 1, "Isto é um teste de escritura."

    'write a locked cell. The cell will not be able to be overwritten, BUT you
    'must set the sheet PROTECTION to on before it will take effect!!!
    .WriteValue xlsText, xlsFont3, xlsLeftAlign, xlsLocked, 9, 1, "Esta celula está protegida"

    'fill the cell with "F"'s
    .WriteValue xlsText, xlsFont0, xlsFillCell, xlsNormal, 10, 1, "F"

    'write a hidden cell to the spreadsheet. This only works for cells
    'that contain formulae. Text, Number, Integer value text can not be hidden
    'using this feature. It is included here for the sake of completeness.
    .WriteValue xlsText, xlsFont0, xlsCentreAlign, xlsHidden, 11, 1, "Se fosse umana fórmula, estaría oculta"


    'write some dates to the file. NOTE: you need to write dates as xlsNumber
    Dim d As Date
    d = "15/01/2001"
    .WriteValue xlsnumber, xlsFont0, xlsCentreAlign, xlsNormal, 15, 1, d, 12

    d = "31/12/1999"
    .WriteValue xlsnumber, xlsFont0, xlsCentreAlign, xlsNormal, 16, 1, d, 12

    d = "01/04/2002"
    .WriteValue xlsnumber, xlsFont0, xlsCentreAlign, xlsNormal, 17, 1, d, 12

    d = "21/10/2003"
    .WriteValue xlsnumber, xlsFont0, xlsCentreAlign, xlsNormal, 18, 1, d, 12

    'PROTECT the spreadsheet so any cells specified as LOCKED will not be
    'overwritten. Also, all cells with HIDDEN set will hide their formulae.
    'PROTECT does not use a password.
    .ProtectSpreadsheet = True


    'Finally, close the spreadsheet
    .CloseFile

    MsgBox "Criou-se um novo ficheiro Excel." & vbCrLf & "Nome: " & FileName$, vbInformation + vbOKOnly, "Criar ficheiro Excel directamente"

    End With


    End Sub
    avatar
    adriano944
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 187
    Registrado : 10/02/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  adriano944 4/6/2010, 09:31

    Vieira....

    só uma duvida...esse modulo dessa imensidão é apenas para criar uma aba no excel atraves do access?
    vieirasoft
    vieirasoft
    Developer
    Developer


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7304
    Registrado : 11/05/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  vieirasoft 4/6/2010, 09:41

    Conforme prometi aqui vai um método simples de criar excel a partir de uma consulta:

    1- Crie uma consulta baseada na sua tabela e chame ConsultaExcel ou outro

    2- Crie uma Pasta chamada Docs em C:\ ou aonde quizer (indique o caminho)

    3- Um botão de comando no form

    On Error Resume Next
    Dim Msg, Style, Title
    Msg = "Esta função cria um ficheiro em Excel na Pasta Docs da sua aplicação" & Chr(13) & Chr(10) & "Deseja continuar?"
    Style = vbYesNo
    Title = "Exportar"
    Msg = MsgBox(Msg, Style, Title)
    If Msg = vbYes Then
    DoCmd.OutputTo acQuery, "sua Consulta", "MicrosoftExcelBiff8(*.xls)", "C:\minha aplicação\Docs\minha Consulta, False, "", 0"
    Else
    End
    End If

    Quanto às celulas não trabalho tanto assim com o excel para o ajudar, mas um dos mestres
    deste fórum vai concerteza ajuda-lo.

    Não esqueça de retornar o seu feedback ao forum para que outros possam aproveitar as experiências trocadas.
    JPaulo
    JPaulo
    Moderador
    Moderador


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 11016
    Registrado : 04/11/2009

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  JPaulo 4/6/2010, 12:41

    Mil maneiras de fazer Nestum;

    Public Sub CriaExcel()
    'By JPaulo ®️ Maximo Access
    'Requer a referencia VBA Microsoft Excel 11.0 Obejct Library (ou 12 para o 2007)

    Dim strAplicacao As New Excel.Application
    Dim strLivro As Excel.Workbook
    Dim strFolha As Excel.Worksheet
    Set strAplicacao = New Excel.Application
    strAplicacao.Visible = False 'não abre o documento, para abrir passe para True
    On Error Resume Next
    Set strLivro = strAplicacao.Workbooks.Add
    Set strFolha = Sheets.Add 'adiciona um sheet novo
    Sheets.Add.Name = "Teste" 'aplica o nome ao sheet novo
    strLivro.SaveAs "c:\teste.xls" 'salva o documento num diretorio
    strLivro.Close False
    Set strLivro = Nothing
    strAplicacao.Quit
    End Sub


    Se for para Exportar para um determinado Excel, tem na Sala de Códigos VBA (Exportar para Excel).


    .................................................................................
    Contribua com o maximoaccess nos links abaixo, ajude a melhorar este que é o seu site na NET.

    Pay-Pal R$ Aqui
    Pay-Pal € Aqui

    Ou ainda: Aqui (Novo)

    Sucesso e Bons Estudos
    Success and Good Studies

    Criar Planilha(Plan1) no Excel atraves do access Folder_announce_new Utilize o Sistema de Busca do Fórum...
    Criar Planilha(Plan1) no Excel atraves do access Folder_announce_new 102 Códigos VBA Gratuitos...
    Criar Planilha(Plan1) no Excel atraves do access Folder_announce_new Instruções SQL como utilizar...
    vieirasoft
    vieirasoft
    Developer
    Developer


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7304
    Registrado : 11/05/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  vieirasoft 4/6/2010, 14:16

    Amigo:
    Que o Módulo +e grande é, mas não fui eu que o fiz e os créditos de quem o fez estão lá inseridos. Agora que funciona eu garanto, pois tenho-o num programa vai para 4 anos e até agora não deu razões de queixa. Mas conforme lhe disse trabalho pouco com o Excel e felizmente nesta selva existe sempre um Mestre disposto a nos ajudar. Fico feliz por isso.

    Abraço
    avatar
    adriano944
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 187
    Registrado : 10/02/2010

    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  adriano944 4/6/2010, 15:37

    Gostaria de agradecer aos dois pela ajuda!

    usei este do JPaulo e funcionou sim..Muito obrigado pessoal!!!

    Conteúdo patrocinado


    Criar Planilha(Plan1) no Excel atraves do access Empty Re: Criar Planilha(Plan1) no Excel atraves do access

    Mensagem  Conteúdo patrocinado


      Data/hora atual: 28/3/2024, 16:04