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: 67674 Skopiuj do schowka Nie działa makro zapisujące plik w 2 róznych lokalizacjach
Autor Wiadomość
guziolek
Starszy Forumowicz


Posty: 39
Wysłany: 30-03-2020, 11:32   Nie działa makro zapisujące plik w 2 róznych lokalizacjach

Cześć!
Mam kłopot bo funkcja nie chce utworzyć folderu w lokalizacji sieciowej. W folderze na dysku lokalnym tworzy. Nie jest to spowodowane ustawieniami sieci, bo jak kod odnosił się tylko do lokalizacji sieciowej to działał, nie działa natomiast dla 2 lokalizacji. Wyświetla komunikat "Ptah not found", to jest akurat jasne, ale powinien utworzyć tą ścieżke, chyba że gdzieś, coś jest źle? Pytanie co?

Kod:
  Sub Przycisk19_Kliknięcie()
Range("a1").Value = Date
Dim nameDir As String
Dim nameDir2 As String
Dim plik As String
Dim parentFolder As String:
parentFolder = [a429]
nameDir = parentFolder & Sheets("oferta").Range("c5").Value & "_" & Sheets("oferta").Range("c6").Value
Set FilePath = CreateObject("Scripting.FileSystemObject")

Dim parentFolder2 As String:
parentFolder2 = [a430]
nameDir2 = parentFolder2 & Sheets("oferta").Range("c5").Value & "_" & Sheets("oferta").Range("c6").Value
Set FilePath = CreateObject("Scripting.FileSystemObject")

'---------

If Not FilePath.FolderExists(nameDir & "\") Then
    FilePath.CreateFolder (nameDir & "\")
    MsgBox "Utworzono nowy katalog" & vbCrLf
End If
 
 plik = nameDir & "\" & _
        Sheets("pomocnicze").Range("a63").Value & "_" & Sheets("oferta").Range("a1").Value & ".pdf"
       
 
 
 
 If Dir(plik) <> "" Then
   If IsFileOpen(plik) Then
      MsgBox "Plik jest otwarty! Zapis nie jest możliwy!"
      Exit Sub
   End If
End If
       
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=plik, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=True

MsgBox "Plik: " & filename & " został zapisany w folderze" & vbCrLf & _
         nameDir
     
     
     '----------


If Not FilePath.FolderExists(nameDir2 & "\") Then
    FilePath.CreateFolder (nameDir2 & "\")
    'MsgBox "Utworzono nowy katalog" & vbCrLf
End If
 
 plik2 = nameDir2 & "\" & _
        Sheets("pomocnicze").Range("a63").Value & "_" & Sheets("oferta").Range("a1").Value & ".pdf"
       
 
 
       
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=plik, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, OpenAfterPublish:=False

'MsgBox "Plik: " & filename & " został zapisany w folderze" & vbCrLf & _
         nameDir2
     
     
End Sub
ID posta: 384510 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 2888 razy
Posty: 9578
Wysłany: 30-03-2020, 18:37   

Spróbuj, czy to zadziała:
Kod:
Sub Przycisk19_Kliknięcie()
    Dim nameDir     As String
    Dim nameDir2    As String
    Dim plik        As String
    Dim plik2       As String
    Dim parentFolder As String
    Dim parentFolder2 As String
    Dim wksPomoc    As Worksheet
    Dim wksOferta   As Worksheet

    parentFolder = Range("A429").Value
    parentFolder2 = Range("A430").Value

    Set wksPomoc = Worksheets("pomocnicze")
    Set wksOferta = Worksheets("oferta")

    With wksOferta
        nameDir = parentFolder & .Range("C5").Value & "_" & .Range("C6").Value
        nameDir2 = parentFolder2 & .Range("C5").Value & "_" & .Range("C6").Value
    End With

    plik = nameDir & "\" & _
           wksPomoc.Range("A63").Value & "_" & _
           wksOferta.Range("A1").Value & ".pdf"

    plik2 = nameDir2 & "\" & _
            wksPomoc.Range("A63").Value & "_" & _
            wksOferta.Range("A1").Value & ".pdf"



    If Not CheckOrCreateMultiFolders(nameDir) Then
        MsgBox "Nie udało się utworzyć folderu:" & vbLf & nameDir, vbCritical
        Exit Sub
    End If

    If Not CheckOrCreateMultiFolders(nameDir2) Then
        MsgBox "Nie udało się utworzyć folderu:" & vbLf & nameDir2, vbCritical
        Exit Sub
    End If

    Range("A1").Value = Date

    '---------

    If Dir(plik) <> "" Then
        If IsFileOpen(plik) Then
            MsgBox "Plik jest otwarty! Zapis nie jest możliwy!"
            Exit Sub
        End If
    End If


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=plik, _
                                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, OpenAfterPublish:=True

    MsgBox "Plik: " & vbLf & _
           plik & vbLf & _
           "został zapisany", vbInformation


    '----------


    If Dir(plik2) <> "" Then
        If IsFileOpen(plik) Then
            MsgBox "Plik jest otwarty! Zapis nie jest możliwy!"
            Exit Sub
        End If
    End If


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=plik2, _
                                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                    IgnorePrintAreas:=False, OpenAfterPublish:=False

    MsgBox "Plik: " & vbLf & _
           plik2 & vbLf & _
           "został zapisany", vbInformation

End Sub


Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer

    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.

    ' Check to see which error occurred.
    Select Case errnum

            ' No error occurred.
            ' File is NOT already open by another user.
        Case 0
            IsFileOpen = False

            ' Error number for "Permission Denied."
            ' File is already opened by another user.
        Case 70
            IsFileOpen = True

            ' Another error occurred.
        Case Else
            Error errnum
    End Select

End Function


Function CheckOrCreateMultiFolders(strPath As String) As Boolean
    'sprawdza, czy cała ścieżka do (pod)foderu istnieje
    'jl. nie, to próbuje ją utworzyć
    'funkcja zwraca:
    ' True - gdy cała ścieżka istnieje lub została pomyślnie utworzona
    ' False - gdy tworzenie się nie powiodło (np. z powodu braku uprawnień)

    Dim retVal      As Long

    If CreateObject("Scripting.FileSystemObject").FolderExists(strPath) Then
        CheckOrCreateMultiFolders = True
    Else
        retVal = CreateObject("Wscript.Shell").Run("cmd /c " & "md """ & strPath & """", 0, True)
        CheckOrCreateMultiFolders = (retVal = 0)
    End If

End Function

Artik
_________________
Persistence is a virtue in the world of programming.
ID posta: 384549 Skopiuj do schowka
 
 
ąćęłńóś
Excel Expert


Pomógł: 268 razy
Posty: 1285
Wysłany: 30-03-2020, 18:57   

guziolek napisał/a:
komunikat "Ptah not found"

"Ptah not found" ... :-> ... hmm ... :->

... w takiej sytuacji żaden kod tu nie zadziała ... należałoby wpierw zacząć od niższych progów ... na wstępie jakiś Apofis, Apis albo nawet Nefertum, ale tak z grubej rury od razu do "naczelnika" walić ?
:-)

Ps.: Niepodeklarowane zmienne, dwa razy z rzędu 'Set FilePath', brak wstępnego określenia zmiennej 'filename' (w dodatku to nazwa właściwości vba), itd. ... tutaj nawet zwykły Imhotep udawałby, że go nie ma ... :->
ID posta: 384551 Skopiuj do schowka
 
 
guziolek
Starszy Forumowicz


Posty: 39
Wysłany: 31-03-2020, 08:20   

Artik, Panie kochany uratowałeś mnie! Serdeczne dzięki, ja ledwo potrafię kod znaleziony w sieci przerobić,a to co Ty zrobiłeś działa idealnie. Co prawda późnym popołudniem wpadłem na to, że nie całą ścieżkę mam w kodzie zadeklarowaną, ale już nie zmieniałem w poście. Miałem nad tym usiąść dzisiaj, a tu taka niespodzianka.
Leci do Ciebie "pomógł"
ID posta: 384574 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