Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
ID tematu: 64145 Skopiuj do schowka Nowy plik Excel za pomocą VB6
Autor Wiadomość
Johan 
Stały bywalec Excelforum


Pomógł: 87 razy
Posty: 299
Wysłany: 15-02-2019, 16:45   Nowy plik Excel za pomocą VB6

Dzień dobry.
W wielokolumnowej kontrolce ListView projektu VB6 posiadam dane, które chcę wydrukować w postaci tabeli w arkuszu Excel (taki powiedzmy "raport"). Popełniłem taki kod:
Kod:
Private Sub Command7_Click()
    Dim exApp As Object
    Dim exSk As Object
    Dim exAr As Object

    Set exApp = CreateObject("Excel.Application")
    exApp.Visible = False
    Set exSk = exApp.Workbooks.Add
    Set exAr = exSk.Worksheets(1)
   
    With exAr.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
    End With
   
    exAr.Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 11
    End With
   
    exAr.Columns(1).ColumnWidth = 9
    exAr.Columns(2).ColumnWidth = 9
    exAr.Columns(3).ColumnWidth = 12
    exAr.Columns(4).ColumnWidth = 15
    exAr.Columns(5).ColumnWidth = 9
    exAr.Columns(6).ColumnWidth = 10
    exAr.Columns(7).ColumnWidth = 8
    exAr.Columns(8).ColumnWidth = 9
    exAr.Columns(9).ColumnWidth = 25
   
    Columns("A:H").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Columns(9).Select
     With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
   
    Rows("2:2").Select
    With Selection.Font
        .Size = 10
        .Bold = True
    End With
   
    i = ListView1.ListItems.Count + 1
   
    exAr.Rows("1:1").RowHeight = 30
    exAr.Rows("2:" & i).RowHeight = 20
    exAr.Cells(1, 1) = "Tytuł raportu"
    exAr.Range("A1:I1").Select
    With Selection
        .Font.Size = 12
        .VerticalAlignment = xlTop
        .MergeCells = True
    End With
   
    exAr.Cells(2, 1) = "kol1"
    exAr.Cells(2, 2) = "kol2"
    exAr.Cells(2, 3) = "kol3"
    exAr.Cells(2, 4) = "kol4"
    exAr.Cells(2, 5) = "kol5"
    exAr.Cells(2, 6) = "kol6"
    exAr.Cells(2, 7) = "kol7"
    exAr.Cells(2, 8) = "kol8"
    exAr.Cells(2, 9) = "kol9"
   
    For i = 3 To i
        exAr.Cells(i, 1) = ListView1.ListItems(i - 2).Text
        exAr.Cells(i, 2) = ListView1.ListItems(i - 2).SubItems(3)
        exAr.Cells(i, 3) = ListView1.ListItems(i - 2).SubItems(4)
        exAr.Cells(i, 4) = ListView1.ListItems(i - 2).SubItems(5)
        exAr.Cells(i, 5) = ListView1.ListItems(i - 2).SubItems(6)
        exAr.Cells(i, 6) = ListView1.ListItems(i - 2).SubItems(7)
        exAr.Cells(i, 7) = ListView1.ListItems(i - 2).SubItems(8)
        exAr.Cells(i, 8) = ListView1.ListItems(i - 2).SubItems(9)
        exAr.Cells(i, 9) = ListView1.ListItems(i - 2).SubItems(10)
    Next i
   
    exAr.Range("A2:I" & i - 1).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
   
    exAr.PrintOut
    Set exAr = Nothing
    exSk.Close SaveChanges:=False
    Set exSk = Nothing
    exApp.Quit
    Set exApp = Nothing
End Sub

Wszystko jest OK jeżeli po uruchomieniu VB wykonam "raport" jeden raz. Jeżeli chcę wykonać "raport" drugi raz program wyrzuca błąd:
Cytat:
Run-time error '91':
Object variable or With block variable not set
wskazując miejsce błędu
Kod:
exAr.Cells.Select
   With Selection.Font
        .Name = "Arial"
        .Size = 11
    End With

zaznaczając linię
Kod:
 With Selection.Font

Jeżeli wyłączę program i uruchomię ponownie "raport" po raz pierwszy działa, przy drugiej próbie wyrzuca błąd.

Próbowałem podobnego działania dla Word i sytuacja identyczna - pierwszy raz działa, drugi raz - błąd. W przypadku Word-a: Run-time error '462'.
W sieci znalazłem informacje o tym, że w przypadku vb i office tak się właśnie dzieje (1 raz ok, drugi error), ale nie znalazłem informacji jak to obejść.
Jeśli któraś z tęgich głów zechciałaby się pochylić na problemem.
ID posta: 362677 Skopiuj do schowka
 
 
Tajan


Pomógł: 4332 razy
Posty: 9625
Wysłany: 15-02-2019, 19:48   

Może nie odwołuj się poprzez obiekt Selection, który jest obiektem Excela a nie VB, lecz bezpośrednio do wybranego obiektu. Czyli, zamiast:
Kod:
exAr.Cells.Select
   With Selection.Font
        .Name = "Arial"
        .Size = 11
    End With

użyj:
Kod:
   With exAr.Cells.Font
        .Name = "Arial"
        .Size = 11
    End With

Ewentualnie, twórz odwołanie do wybranych obiektów poprzez zmienną:
Kod:

Dim exObj as Object
'...
   Set exObj = exAr.Cells

   With exObj.Font
        .Name = "Arial"
        .Size = 11
    End With
Oczywiście, dotyczy to również i dalszych odwołań poprzez Selection. Przy czym na pewno nie można odwoływać się w taki sposób:
Kod:
Columns("A:H").Select

Należałoby jawnie odwołać się do arkusza Excela, a nie zdawać się na domyślność VB:
Kod:
exAr.Columns("A:H").Select
chociaż jak wpisałem wcześniej, nie ma potrzeby zaznaczania obiektów arkusza:
Kod:
With exAr.Columns("A:H")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Ostatnio zmieniony przez Tajan 15-02-2019, 21:09, w całości zmieniany 1 raz  
ID posta: 362680 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2117 razy
Posty: 7009
Wysłany: 15-02-2019, 20:42   

Mi tak to wyszło:
Kod:
Private Sub Command7_Click()
    Dim exApp          As Object
    Dim exSk           As Object
    Dim exAr           As Object

    Set exApp = CreateObject("Excel.Application")
    Application.ScreenUpdating = False
    exApp.Visible = False
    Set exSk = exApp.Workbooks.Add
    Set exAr = exSk.Worksheets(1)

    With exAr.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .Orientation = xlLandscape
        .PaperSize = xlPaperA4
    End With

    With exAr.Cells.Font
        .Name = "Arial"
        .Size = 11
    End With

    exAr.Range("A:A,B:B,E:E,H:H").ColumnWidth = 9
    exAr.Columns(3).ColumnWidth = 12
    exAr.Columns(4).ColumnWidth = 15
    exAr.Columns(6).ColumnWidth = 10
    exAr.Columns(7).ColumnWidth = 8
    exAr.Columns(9).ColumnWidth = 25

    With Columns("A:I")
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

    Columns(9).HorizontalAlignment = xlLeft

    With Rows(2).Font
        .Size = 10
        .Bold = True
    End With

    i = ListView1.ListItems.Count + 1

    exAr.Rows("1:1").RowHeight = 30
    exAr.Rows("2:" & i).RowHeight = 20
    exAr.Cells(1, 1) = "Tytuł raportu"

    With exAr.Range("A1:I1")
        .Font.Size = 12
        .VerticalAlignment = xlTop
        .MergeCells = True
    End With
    exAr.Range("A2:H2").Value = Array("kol1", "kol2", "kol3", "kol4", "kol5", "kol6", "kol7", "kol8", "kol9")


    For i = 3 To i   ' a tu i=3 do 3 ????? Po co ta niby petla ????
        exAr.Cells(i, 1) = ListView1.ListItems(i - 2).Text
        exAr.Cells(i, 2) = ListView1.ListItems(i - 2).SubItems(3)
        exAr.Cells(i, 3) = ListView1.ListItems(i - 2).SubItems(4)
        exAr.Cells(i, 4) = ListView1.ListItems(i - 2).SubItems(5)
        exAr.Cells(i, 5) = ListView1.ListItems(i - 2).SubItems(6)
        exAr.Cells(i, 6) = ListView1.ListItems(i - 2).SubItems(7)
        exAr.Cells(i, 7) = ListView1.ListItems(i - 2).SubItems(8)
        exAr.Cells(i, 8) = ListView1.ListItems(i - 2).SubItems(9)
        exAr.Cells(i, 9) = ListView1.ListItems(i - 2).SubItems(10)
    Next i

    exAr.Range("A2:I" & i - 1).Borders.Weight = xlHairline

    exAr.PrintOut
    exSk.Close SaveChanges:=False
    exApp.Quit

    Set exAr = Nothing
    Set exSk = Nothing
    Set exApp = Nothing
End Sub

Czy zadziała nie wiem - nie testowałem.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 362681 Skopiuj do schowka
 
 
Tajan


Pomógł: 4332 razy
Posty: 9625
Wysłany: 15-02-2019, 21:09   

Marecki, jak pisałem wyżej, nie jestem pewien, czy zapis w rodzaju:
Kod:
 With Columns("A:I")
będzie poprawny. Ja raczej radziłbym:
Kod:
 With  exAr.Columns("A:I")
ID posta: 362682 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2117 razy
Posty: 7009
Wysłany: 15-02-2019, 21:13   

Aaaa, prawda, odwoływać się jawnie.
Bardziej starałem się skrócić kod i pozbyć się Select-ów.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 362683 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 198 razy
Posty: 937
Wysłany: 16-02-2019, 01:56   

Ciekawe, czy tak podejdzie (?):
Kod:
Private Sub Command7_Click()
    Dim exApp As Object, exSk As Object, exAr As Object
    Dim i As Integer, j As Integer, k As Integer, indks As Integer, wrwn As Integer
    Dim szer As Variant
   
    szer = Array(9, 9, 12, 15, 9, 10, 8, 9, 25)
    indks = UBound(szer)
    wrwn = -4108                                ' xlCenter
    k = ListView1.ListItems.Count + 1
   
    Set exApp = CreateObject("Excel.Application")
    exApp.Visible = False
    Set exSk = exApp.Workbooks.Add
    Set exAr = exSk.Worksheets(1)
   
    With exAr
        With .Cells.Font
            .Name = "Arial"
            .Size = 11
        End With
       
        For i = 0 To indks
            With .Columns(i + 1)
                .ColumnWidth = szer(i)
                If i = indks Then wrwn = -4131  ' xlLeft
                .HorizontalAlignment = wrwn     ' xlCenter / xlLeft
                .VerticalAlignment = xlCenter
            End With
        Next
       
        With .Range("A1:I1")
            .Cells(1).Value = "Tytuł raportu"
            .EntireRow.RowHeight = 30
            .Font.Size = 12
            .VerticalAlignment = xlTop
            .MergeCells = True
        End With
       
        With .Rows("2:2")
            .Resize(k).RowHeight = 20
            With .Font
                .Size = 10
                .Bold = True
            End With
        End With
       
        For i = 0 To indks
            .Cells(2, i + 1).Value = "kol" & CStr(i + 1)
        Next
       
        For i = 3 To k
            .Cells(i, 1) = ListView1.ListItems(i - 2).Text
            For j = 2 To indks
                .Cells(i, j) = ListView1.ListItems(i - 2).SubItems(j + 1)
            Next
        Next
       
        With .Range("A2:I" & k - 1)             'Czy na pewno 'k - 1', a nie 'k' ?
            For i = 5 To 6
                .Borders(i).LineStyle = xlNone  ' -4142
            Next
           
            For i = 7 To 12
                With .Borders(i)
                    .LineStyle = xlContinuous   ' 1
                    .ColorIndex = xlAutomatic   '-4105
                    .TintAndShade = 0
                    .Weight = xlHairline        '1
                End With
            Next
        End With
       
        With .PageSetup
            .LeftMargin = Application.InchesToPoints(0.393700787401575)
            .RightMargin = Application.InchesToPoints(0.393700787401575)
            .TopMargin = Application.InchesToPoints(0.393700787401575)
            .BottomMargin = Application.InchesToPoints(0.393700787401575)
            .HeaderMargin = Application.InchesToPoints(0.31496062992126)
            .FooterMargin = Application.InchesToPoints(0.31496062992126)
            .Orientation = xlLandscape
            .PaperSize = xlPaperA4
        End With
       
        .PrintOut
    End With
   
    Set exAr = Nothing
    exSk.Close SaveChanges:=False
    Set exSk = Nothing
    exApp.Quit
    Set exApp = Nothing
End Sub


Kod:
'HorizontalAlignment:
    'xlCenter = -4108 ; xlDistributed = -4117 ; lJustify = -4130 ; xlLeft = -4131 ; xlRight = -4152
'VerticalAlignment:
    'xlBottom = -4107 ; xlCenter = -4108 ; xlDistributed = -4117 ; xlJustify = -4130 ; xlTop = -4160
'XlBordersIndex:
    'xlDiagonalDown = 5 ; xlDiagonalUp = 6 ; xlEdgeLeft = 7 ; xlEdgeTop = 8
    'xlEdgeBottom = 9 ; xlEdgeRight = 10 ; xlInsideVertical = 11 ; xlInsideHorizontal = 12
ID posta: 362690 Skopiuj do schowka
 
 
Johan 
Stały bywalec Excelforum


Pomógł: 87 razy
Posty: 299
Wysłany: 16-02-2019, 16:42   

Dziękuję za zainteresowanie. :beer
W kolejności:
-kol. Tajan: wygląda na to, że istotą problemu było "Selection". Zastosowałem się do Twoich sugestii i zadziałało;

-kol. Marecki: tu wyrzuca błąd:
Kod:
exAr.Range("A:A,B:B,E:E,H:H").ColumnWidth = 9
wróciłem do mojego sposobu ustalania szer. kol. i wówczas uruchamia się Excel, nie otwiera nowego skoroszytu, mimo wszystko przelatuje cały kod (na szybko nie wiem czy drukuje, ustawiłem exApp.Visible na true i opisuję co widzę);

-kol. ąćęłńóś:
Kod:
'Czy na pewno 'k - 1', a nie 'k' ?
a nawet k+1, poza tym kod działa, ale nie "wpisuje" 9 kolumny (sprawdziłem krokowo i
Kod:
indks = UBound(szer)
=8, a powinno 9 i tu jest problem).

Generalnie na chwilę obecną wykorzystam sugestie Tajana.
Jeszcze raz serdecznie dziękuję za pomoc :beer
ID posta: 362711 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 198 razy
Posty: 937
Wysłany: 16-02-2019, 20:44   

Johan napisał/a:
... nie "wpisuje" 9 kolumny (sprawdziłem krokowo ...

Standardowo vb liczy od 0, a więc 8 to indeks 9-ty ... nie masz przypadkiem 'Option Base 1' w module ?
Dla spokoju sumienia sprawdziłem i nijak nie chce wychodzić inaczej jak dla 9-ciu kolumn ... :->
Kod:
Sub aaa()
    Dim szer, indks%, i%
    szer = Array(10, 10, 10, 10, 10, 10, 10, 10, 10)
    indks = UBound(szer)
   
    For i = 0 To indks
        Cells(1, i + 1).Value = i + 1
        Columns(i + 1).ColumnWidth = szer(i)
    Next
End Sub
ID posta: 362727 Skopiuj do schowka
 
 
Johan 
Stały bywalec Excelforum


Pomógł: 87 razy
Posty: 299
Wysłany: 18-02-2019, 09:25   

Cytat:
Standardowo vb liczy od 0
Wybacz, niedziela, kawa, brak logicznego myślenia. :hamer
ID posta: 362801 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe