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: 75347 Skopiuj do schowka Przenoszenie danych z tabeli Ms Access do tabeli Ms Word
Autor Wiadomość
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 09-12-2023, 09:11   Przenoszenie danych z tabeli Ms Access do tabeli Ms Word

Jak zmienić zapis żeby rekordy z tabeli tbl_Contacts były wybierane z pola listy w zależności od zaznaczenia a nie z pola kombi


Kod:
 sDocFile = CurrentProject.Path & "\SomeWordDocument.docx"
    Call Export2DOC(sDocFile, "SELECT * FROM tbl_Contacts WHERE ID=" & Me.cbo_ContactName)
    End Sub

Dim sDocFile As String
    sDocFile = CurrentProject.Path & "\SomeWordDocument.docx"
    Call Export2DOC(sDocFile, "SELECT * FROM tbl_Contacts WHERE ID=" & Me.Lista17)                                       



mam taki błąd jak w załączniku

Zrzut ekranu 2023-12-09 090036.png
Plik ściągnięto 25 raz(y) 47.91 KB

ID posta: 432036 Skopiuj do schowka
 
 
Tajan


Pomógł: 5530 razy
Posty: 12010
Wysłany: 09-12-2023, 11:40   

Na podstawie obrazka trudno określić przyczynę błędu. Tym bardziej, ze nie wiadomo czym jest "Lista17". Jeżeli to formant ActiveX to może należy sprawdzić czy coś zostało wybrane z listy. Coś takiego:
Kod:
If Me.Lista17.ListIndex > -1 Then
     Call Export2DOC(sDocFile, "SELECT * FROM tbl_Contacts WHERE ID=" & Me.Lista17.Value)
 Else
    MsgBox "Wybierz kontakt z listy"
End If
ID posta: 432042 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1293 razy
Posty: 2637
Wysłany: 10-12-2023, 00:55   

jeżeli ListBox ma własność Multiselect=0, wtedy można zrobic tak jak Tajan napisal.
Widzę jednak że masz multiselect=1 lub 2
więc nawet jak zrobisz jak Tajan radzi to błąd nadal będzie bo warunek listindex > -1 jest spełniony, a Lista17.Value wygeneruje błąd

więc teraz pytanie:
czy chcesz w zapytaniu porównać w klauzuli WHERE pierwszy zaznaczony ID ?
Kod:
Call Export2DOC(sDocFile, "SELECT * FROM tbl_Contacts WHERE ID = " & Lista17.ItemData(Lista17.ItemsSelected(0)))


czy wszystkie ?
Kod:

Dim sIN As String
For Each i In Lista17.ItemsSelected
    sIN = sIN & IIf(Len(sIN) > 0, ", ", "") & Lista17.ItemData(i)
Next
Call Export2DOC(sDocFile, "SELECT * FROM tbl_Contacts WHERE ID IN (" & sIN & ")")
_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 432048 Skopiuj do schowka
 
 
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 10-12-2023, 13:00   

Tajan jest tak jak master_mix napisał Lista17.Value wygenerowała błąd wcześniej podałem za mało informacji do pomocy ale dzięki za wpis.

master_mix chcę porównać w klauzuli WHERE wszystkie
kod działa doskonale zadeklarowałem tylko Dim i As Variant bo brakowało.

Teraz w moim projekcie zostały dwa tematy
1.formatowania tabeli np. format liczby walutowy nie przenoszą się formatowania z Access do Word dodatkowo pewne dane chcę pogrubić w Wordzie
2. umieszczenie tabeli w innym miejscu niż na pierwszej stronie dokumentu bo tak się obecnie dzieję.

może jakieś sugestie w tym temacie kod poniżej

Kod:
Function Export2DOC(sDocFile As String, sQuery As String)
    Dim oWord           As Object
    Dim oWordDoc        As Object
    Dim oWordTbl        As Object
    Dim bWordOpened     As Boolean
    Dim db              As DAO.Database
    Dim rs              As DAO.Recordset
    Dim iCols           As Integer
    Dim iRecCount       As Integer
    Dim iFldCount       As Integer
    Dim i               As Integer
    Dim j               As Integer
    Const wdPrintView = 3
    Const wdWord9TableBehavior = 1
    Const wdAutoFitFixed = 0
    Const xlLandscape = 2

    'Start Word
    On Error Resume Next
    Set oWord = GetObject("Word.Application")    'Bind to existing instance of Word

    If Err.Number <> 0 Then    'Could not get instance of Word, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oWord = CreateObject("Word.application")
        bWordOpened = False
    Else    'Word was already running
        bWordOpened = True
    End If
    On Error GoTo Error_Handler
    oWord.Visible = True
    Set oWordDoc = oWord.Documents.Open(sDocFile)

    'Open our SQL Statement, Table, Query
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            .MoveLast   'Ensure proper count
            iRecCount = .RecordCount    'Number of records returned by the table/query
            .MoveFirst
            iFldCount = .Fields.Count   'Number of fields/columns returned by the table/query

            oWord.ActiveWindow.View.Type = wdPrintView    'Switch to print preview mode (not req'd just a personal preference)
            oWordDoc.PageSetup.TogglePortrait   'Switch to landscape
            oWord.ActiveDocument.Tables.Add Range:=oWord.Selection.Range, NumRows:=iRecCount + 1, NumColumns:= _
                                            iFldCount, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
                                            wdAutoFitFixed

            Set oWordTbl = oWordDoc.Tables(1)
            'Build our Header Row
            For i = 0 To iFldCount - 1
                oWordTbl.Cell(1, i + 1) = rs.Fields(i).Name
            Next i
            'Build our data rows
            For i = 1 To iRecCount
                For j = 0 To iFldCount - 1
                    oWordTbl.Cell(i + 1, j + 1) = Nz(rs.Fields(j).Value, "")
                Next j
                .MoveNext
            Next i
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Word spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With

    '    oWordDoc.Close True, sFileName 'Save and close

    'Close Word if is wasn't originally running
    '    If bWordOpened = False Then
    '        oWord.Quit
    '    End If

Error_Handler_Exit:
    On Error Resume Next
    oWord.Visible = True   'Make Word visible to the user
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set oWordTbl = Nothing
    Set oWordDoc = Nothing
    Set oWord = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: Export2DOC" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function
ID posta: 432052 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1293 razy
Posty: 2637
Wysłany: 10-12-2023, 22:47   

nie bardzo wiem co masz na myśli że format walutowy się nie przenosi...
ale zawsze możesz sprawdzić jaki typ danych jest w konkretnym polu recordseta i sformatować po swojemu.
Czy tabelę chcesz wstawiać na nowej stronie dokumentu? bo też nie sprecyzowałeś.
Ale zakładam że otwierany dokument jest jakimś szablonem i chcesz wstawić na nowej stronie.
Kod:

Function Export2DOC(sDocFile As String, sQuery As String)
    Dim oWord           As Object
    Dim oWordDoc        As Object
    Dim oWordTbl        As Object
    Dim bWordOpened     As Boolean
    Dim db              As DAO.Database
    Dim rs              As DAO.Recordset
    Dim iCols           As Integer
    Dim iRecCount       As Integer
    Dim iFldCount       As Integer
    Dim i               As Integer
    Dim j               As Integer
    Const wdPrintView = 3
    Const wdWord9TableBehavior = 1
    Const wdAutoFitFixed = 0
    Const xlLandscape = 2
   
    'Start Word
    On Error Resume Next
    Set oWord = GetObject("Word.Application")    'Bind to existing instance of Word
   
    If Err.Number <> 0 Then    'Could not get instance of Word, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oWord = CreateObject("Word.application")
        bWordOpened = False
    Else    'Word was already running
        bWordOpened = True
    End If
    On Error GoTo Error_Handler
    oWord.Visible = True
    Set oWordDoc = oWord.Documents.Open(sDocFile)
   
    'Open our SQL Statement, Table, Query
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            .MoveLast   'Ensure proper count
            iRecCount = .RecordCount    'Number of records returned by the table/query
            .MoveFirst
            iFldCount = .Fields.Count   'Number of fields/columns returned by the table/query
           
            oWord.ActiveWindow.View.Type = wdPrintView    'Switch to print preview mode (not req'd just a personal preference)
            oWordDoc.PageSetup.TogglePortrait   'Switch to landscape
           
            Dim rngNewPage As Object
            Set rngNewPage = oWordDoc.Content
            rngNewPage.Start = oWordDoc.Content.End
            rngNewPage.InsertBreak Type:=7
            Set oWordTbl = oWord.ActiveDocument.Tables.Add(Range:=rngNewPage, NumRows:=iRecCount + 1, NumColumns:= _
                iFldCount, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
                wdAutoFitFixed)
                 
            Dim wCell As Object
            'Build our Header Row
            For i = 0 To iFldCount - 1
                oWordTbl.Cell(1, i + 1) = rs.Fields(i).Name
            Next i
            'Build our data rows
            For i = 1 To iRecCount
                For j = 0 To iFldCount - 1
                    Set wCell = oWordTbl.Cell(i + 1, j + 1)
                    If VarType(rs.Fields(j).Value) = vbCurrency Then
                        wCell.Range.Text = Format(Nz(rs.Fields(j).Value, ""), "$# ###.##") 'formatuj po swojemu
                    Else
                        wCell.Range.Text = Nz(rs.Fields(j).Value, "")
                    End If
                    If j = 3 Then 'TUTAJ WARUNEK KIEDY BOLD'OWAĆ
                        wCell.Range.Bold = True
                    End If
                Next j
                .MoveNext
            Next i
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Word spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With
   
    'oWordDoc.Close True, sFileName 'Save and close
   
   
    'Close Word if is wasn't originally running
    'If bWordOpened = False Then
    '  oWord.Quit
    'End If
   
   
Error_Handler_Exit:
    On Error Resume Next
    oWord.Visible = True   'Make Word visible to the user
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set oWordTbl = Nothing
    Set oWordDoc = Nothing
    Set oWord = Nothing
    Exit Function
   
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
        "Error Number: " & Err.Number & vbCrLf & _
        "Error Source: Export2DOC" & vbCrLf & _
        "Error Description: " & Err.Description _
        , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function
_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 432067 Skopiuj do schowka
 
 
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 12-12-2023, 20:43   

Formatowanie działa świetnie dzięki master_mix

Pozostaje temat umieszczenia tabeli w odpowiednim miejscu nie na nowej stronie tylko w określonej linii paragrafie
ID posta: 432105 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1293 razy
Posty: 2637
Wysłany: 12-12-2023, 21:14   

zamień to:
Kod:
Dim rngNewPage As Object
            Set rngNewPage = oWordDoc.Content
            rngNewPage.Start = oWordDoc.Content.End
            rngNewPage.InsertBreak Type:=7
            Set oWordTbl = oWord.ActiveDocument.Tables.Add(Range:=rngNewPage, NumRows:=iRecCount + 1, NumColumns:= _
                iFldCount, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
                wdAutoFitFixed)


na to (oczywiście wybierz odpowiedni paragraphs):
Kod:
Dim rngNewPage As Object
            Set rngNewPage = oWordDoc.Paragraphs(1).Range
            Set oWordTbl = oWord.ActiveDocument.Tables.Add(Range:=rngNewPage, NumRows:=iRecCount + 1, NumColumns:= _
                iFldCount, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
                wdAutoFitFixed)
_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 432106 Skopiuj do schowka
 
 
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 12-12-2023, 21:31   

zmieniam oWordDoc.Paragraphs(1).Range na oWordDoc.Paragraphs(9).Range i jest błąd

Zrzut ekranu 2023-12-12 212928.png
Plik ściągnięto 3 raz(y) 15.22 KB

ID posta: 432107 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1293 razy
Posty: 2637
Wysłany: 12-12-2023, 21:49   

Więc z tego wynika że paragraphs9 nie istnieje w dokumencie
_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 432108 Skopiuj do schowka
 
 
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 12-12-2023, 21:56   

Tak masz rację dla testu wstawiłem w Wordzie 8 zamiast 9 jest ok. Wielkie dzięki
ID posta: 432109 Skopiuj do schowka
 
 
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 16-12-2023, 07:43   

Jednak muszę zmienić koncepcję ciężko jest wskazać miejsce tabeli w konkretnym paragrafie, ponieważ dane przed nim się zmieniają co przesuwa wskazany paragraf.
Chcę żeby tabela była zawsze pod punktem 7.1. Nazwa jest to stały tekst może macie jakieś rozwiązania
ID posta: 432199 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1293 razy
Posty: 2637
Wysłany: 17-12-2023, 01:14   

trzecim argumentem jest szukany tekst
Kod:
Function Export2DOC(sDocFile As String, sQuery As String, findText As String)
    Dim oWord           As Object
    Dim oWordDoc        As Object
    Dim oWordTbl        As Object
    Dim bWordOpened     As Boolean
    Dim db              As DAO.Database
    Dim rs              As DAO.Recordset
    Dim iCols           As Integer
    Dim iRecCount       As Integer
    Dim iFldCount       As Integer
    Dim i               As Integer
    Dim j               As Integer
    Const wdPrintView = 3
    Const wdWord9TableBehavior = 1
    Const wdAutoFitFixed = 0
    Const xlLandscape = 2
   
    'Start Word
    On Error Resume Next
    Set oWord = GetObject("Word.Application")    'Bind to existing instance of Word
   
    If Err.Number <> 0 Then    'Could not get instance of Word, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oWord = CreateObject("Word.application")
        bWordOpened = False
    Else    'Word was already running
        bWordOpened = True
    End If
    On Error GoTo Error_Handler
    oWord.Visible = True
    Set oWordDoc = oWord.Documents.Open(sDocFile)
   
    'Open our SQL Statement, Table, Query
    Set db = CurrentDb
    Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot)
    With rs
        If .RecordCount <> 0 Then
            .MoveLast   'Ensure proper count
            iRecCount = .RecordCount    'Number of records returned by the table/query
            .MoveFirst
            iFldCount = .Fields.Count   'Number of fields/columns returned by the table/query
           
            oWord.ActiveWindow.View.Type = wdPrintView    'Switch to print preview mode (not req'd just a personal preference)
            oWordDoc.PageSetup.TogglePortrait   'Switch to landscape
           
            Dim rngNewPage As Object
            Set rngNewPage = oWordDoc.Content
            rngNewPage.Find.Execute findText
            If rngNewPage.Find.Found Then
                rngNewPage.MoveEnd 3
                rngNewPage.Start = rngNewPage.End
                rngNewPage.InsertParagraphAfter
                Set oWordTbl = oWord.ActiveDocument.Tables.Add(Range:=rngNewPage, NumRows:=iRecCount + 1, NumColumns:= _
                    iFldCount, DefaultTableBehavior:=1, AutoFitBehavior:=0)
               
                Dim wCell As Object
                'Build our Header Row
                For i = 0 To iFldCount - 1
                    oWordTbl.Cell(1, i + 1) = rs.Fields(i).Name
                Next i
                'Build our data rows
                For i = 1 To iRecCount
                    For j = 0 To iFldCount - 1
                        Set wCell = oWordTbl.Cell(i + 1, j + 1)
                        If VarType(rs.Fields(j).Value) = vbCurrency Then
                            wCell.Range.Text = Format(Nz(rs.Fields(j).Value, ""), "$# ###.##") 'formatuj po swojemu
                        Else
                            wCell.Range.Text = Nz(rs.Fields(j).Value, "")
                        End If
                        If j = 3 Then 'TUTAJ WARUNEK KIEDY BOLD'OWAĆ
                            wCell.Range.Bold = True
                        End If
                    Next j
                    .MoveNext
                Next i
            Else
                MsgBox "text not found"
            End If
        Else
            MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Word spreadsheet with"
            GoTo Error_Handler_Exit
        End If
    End With
   
    'oWordDoc.Close True, sFileName 'Save and close
    'Close Word if is wasn't originally running
    'If bWordOpened = False Then
    '  oWord.Quit
    'End If
   
Error_Handler_Exit:
    On Error Resume Next
    oWord.Visible = True   'Make Word visible to the user
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set oWordTbl = Nothing
    Set oWordDoc = Nothing
    Set oWord = Nothing
    Exit Function
   
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
        "Error Number: " & Err.Number & vbCrLf & _
        "Error Source: Export2DOC" & vbCrLf & _
        "Error Description: " & Err.Description _
        , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
   
End Function

_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 432209 Skopiuj do schowka
 
 
sowa_222 
Stały bywalec Excelforum


Wersja: Win Office 2010
Posty: 281
Wysłany: 17-12-2023, 09:09   

jeszcze jest taki błąd

Zrzut ekranu 2023-12-17 090401.png
Plik ściągnięto 8 raz(y) 42.55 KB

ID posta: 432211 Skopiuj do schowka
 
 
master_mix 
Excel Expert



Wersja: Win Office 365
Pomógł: 1293 razy
Posty: 2637
Wysłany: 17-12-2023, 10:19   

No przecież żem pisał
master_mix napisał/a:
trzecim argumentem jest szukany tekst
;-)
Kod:

Call Export2DOC(sDocFile, "SELECT * FROM tbl_Contacts WHERE ID IN (" & sIN & ")", "7.1")
_________________

Podejmę współpracę (pracę)
Programowanie C#, Android, iOS, VB.NET, VBA, ASP.NET Core, WPF, Xamarin, Power Platforms, XAML, MVC, LINQ, Entity Framework. Bazy danych SQL Server, Oracle, MySQL, Firebird
Wrocław i okolice …lub zdalnie.
ID posta: 432212 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.wip.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