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: 67204 Skopiuj do schowka zapisanie pliku worda na dysku
Autor Wiadomość
stavic
Exceloholic


Posty: 199
Wysłany: 09-02-2020, 12:42   zapisanie pliku worda na dysku

Mam poniższe makro które generuje mi plik worda jednak go nie zapisuje na dysku w (lokalizacja taka sama jak plik excela)
Kod:

Sub DrukujDoWorda()
    Dim WordApp     As Object
    Dim nazwa       As String
    Dim SaveAsName  As String
    Dim wksSwiad    As Worksheet
    Dim wksTmp      As Worksheet
    Dim rngFiltered As Range
    Dim rngFltrData As Range
    Dim WdDoc       As Object
    Dim WdRng       As Object
    Dim vFltrData   As Variant
    Dim i           As Long
    Dim k           As Long
  Const wdAlignParagraphLeft As Long = 0
    Const wdAlignParagraphCenter As Long = 1
    Const wdAlignParagraphRight As Long = 2


    Const wdCollapseEnd As Long = 0
    Const wdAlignParagraphJustify As Long = 3
    Const wdParagraph As Long = 4

    'kontrola wersji Office'a
    If Val(Application.Version) < 10 Then
        MsgBox "Ta metoda działa na offisie od wersji 2002"
        Exit Sub
    End If

    Set wksSwiad = Worksheets("swiadectwo")

    If Not wksSwiad.AutoFilterMode Then
        wksSwiad.Range("A12").AutoFilter
    End If

    'zakres całej tabeli z aktywnym autofiltrem
    Set rngFiltered = wksSwiad.AutoFilter.Range

    'zakres danych w tabeli filtrowanej
    With rngFiltered
        Set rngFiltered = .Offset(1).Resize(.Rows.Count - 1)
    End With

    On Error Resume Next
    'tylko widoczne komórki w zakresie kolumn I:K, bez nagłówków tabeli
    Set rngFltrData = Intersect(rngFiltered.SpecialCells(xlCellTypeVisible), wksSwiad.Range("I:K,U:U,AA:AA"))
    On Error GoTo 0

    If rngFltrData Is Nothing Then
        MsgBox "Brak danych do skopiowania.", vbExclamation
        Exit Sub
    End If

    'dodaj tymczasowy arkusz
    Set wksTmp = ThisWorkbook.Worksheets.Add

    'skopiuj przefiltrowane komórki i wklej do A1 nowego arkusza
    '(otrzymamy ciągły zakres danych)
    rngFltrData.Copy wksTmp.Cells(1)

    'zapamiętaj dane w zmiennej
    vFltrData = wksTmp.Cells(1).CurrentRegion.Value

    'usuń arkusz tymczasowy
    Application.DisplayAlerts = False
    wksTmp.Delete
    Application.DisplayAlerts = True

    'Stop
    On Error Resume Next
    'uruchamianie Worda i utworzenie obiektu (późne wiązanie)
    Set WordApp = CreateObject("Word.Application")
    On Error GoTo 0

    If WordApp Is Nothing Then
        MsgBox "Woops, chyba nie ma Word-a!", vbCritical
        Exit Sub
    End If


    nazwa = wksSwiad.Range("A1") & " - " & wksSwiad.Range("B1")
    'nazwa = ZamZnakiNiedozwolone(nazwa)     'funkcja usuwająca znaki niedozwolone

    SaveAsName = ThisWorkbook.Path & "\" & nazwa & ".doc"

    Set WdDoc = WordApp.Documents.Add

    With WdDoc.PageSetup    'parametry marginesow
        .TopMargin = WordApp.CentimetersToPoints(1.5)
        .BottomMargin = WordApp.CentimetersToPoints(1.5)
        .LeftMargin = WordApp.CentimetersToPoints(3.5)
        .RightMargin = WordApp.CentimetersToPoints(1.5)
        .FooterDistance = WordApp.CentimetersToPoints(1.5)
    End With

    Set WdRng = WdDoc.Content

    With WdRng
        .Font.Name = "Arial"
        .Font.Size = 12
        .ParagraphFormat.SpaceBefore = 0
        .ParagraphFormat.SpaceAfter = 0
        .ParagraphFormat.LineSpacing = 15    'pojedyncze odstepy miedzy wierszami
    End With

    'TREŚĆ dwa entery na początku
    WdDoc.Content.InsertParagraphAfter
   
    WdDoc.Content.InsertParagraphAfter


    Set WdRng = WdDoc.Content
    WdRng.Collapse Direction:=wdCollapseEnd


    With WdRng

        For i = 1 To UBound(vFltrData)

            For k = 1 To UBound(vFltrData, 2)
                WdRng.Text = vFltrData(i, k) & vbCr

                With WdRng.Paragraphs(1).Range
                    Select Case k
                        Case 1
                            'nic nie musimy zmieniać, bo "normalna do lewej"
                            'to wartości domyślne
                        Case 2
                            .ParagraphFormat.Alignment = wdAlignParagraphCenter
                            'nie musimy dodawać .Font.Bold = False
                            'bo to wartość domyślna
                        Case 3
                            .ParagraphFormat.Alignment = wdAlignParagraphCenter
                            .Font.Bold = True
                        Case 4 To 5
                            .ParagraphFormat.Alignment = wdAlignParagraphRight
                        Case Else
                            MsgBox "Nie zdefiniowana kolumna!", vbExclamation, "Babol programisty"
                            Stop
                    End Select
                End With

                WdRng.Move Unit:=wdParagraph, Count:=1

            Next k

            .InsertParagraph
            WdRng.Move Unit:=wdParagraph, Count:=1
        Next i

    End With



    WdRng.Delete

    MsgBox "świadectwo o nazwie:" & vbNewLine & _
           nazwa & vbNewLine & _
           "zostało utworzone i otworzone w tle." & vbNewLine & _
           vbNewLine & _
           "Możesz je normalnie edytować." & vbNewLine & _
           "Jeśli chcesz zarchiwizawać dokument zapisz go - F12"

    WordApp.Visible = True
    WordApp.Activate

    Set WdRng = Nothing
    Set WdDoc = Nothing
    Set WordApp = Nothing


End Sub


kombinowałem z wpisaniem
Kod:
.ActiveDocument.SaveAs Filename:=SaveAsName

Proszę o poprawę kodu tak, aby plik worda został zapisany w tej samej lokalizacji co plik excela ( i był otwarty jak dotychczas).
ID posta: 381385 Skopiuj do schowka
 
 
J_B 
Excel Expert


Wersja: Win Office 2016
Pomógł: 416 razy
Posty: 1088
Wysłany: 09-02-2020, 14:33   

stavic napisał/a:
aby plik worda został zapisany w tej samej lokalizacji co plik excela

Kod:
.ActiveDocument.SaveAs2 Filename:=ThisWorkbook.Path & "\Nazwa.docx"
ID posta: 381387 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2888 razy
Posty: 9578
Wysłany: 10-02-2020, 00:31   

Tą linią
Kod:
Set WdDoc = WordApp.Documents.Add
"utworzyłeś" ;-) odwołanie do dokumentu. I powinieneś się tego trzymać
Kod:
WdDoc.SaveAs Filename:=SaveAsName
Na nowszych wersjach może też być SaveAs2. Zapis powinien być przed zniszczeniem zmiennych (na końcu procedury).

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 381408 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