Forum

Forum (https://www.ms-office.gr/forum/)
-   Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)
-   -   Εξαγωγή αρχείου σε μορφή pdf με επιλογή θέσης και με alarm ύπαρξης ίδιου ονόματος (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/4561-eksagogi-arxeioy-se-morfi-pdf-me-epilogi-thesis-kai-me-alarm-iparksis-idioy-onomatos.html)

ΤΙΜΟΣ 03-05-17 16:38
Εξαγωγή αρχείου σε μορφή pdf με επιλογή θέσης και με alarm ύπαρξης ίδιου ονόματος
 
Χρόνια Πολλά σ' όλους
Χριστός Ανέστη.
Για άλλη μία φορά θα χρειαστώ την βοήθεια από τα μέλη του φόρουμ. Παραθέτω δύο κώδικες, τους οποίους μου τους έστειλε ο Γιώργος (kapetang) σε παλαιότερα θέματα που είχα ζητήσει βοήθεια και εκτελούν τις ακόλουθες εντολές:
Ο 1ος μας επιτρέπει να αποθηκεύσουμε σε μορφή pdf έκθεση σε φάκελο που θα επιλέξουμε εμείς.
Ο 2ος μας προειδοποιεί για την ύπαρξη αρχείου με το ίδιο όνομα σε προκαθορισμένο φάκελο.
Αυτό που θέλω να πετύχω και δεν μπόρεσα, αν και έχω κάνει αρκετές προσπάθειες, να μπορέσω να "παντρέψω" τους δύο κώδικες. Δηλ. ένας κώδικας που με μία εντολή να γίνεται η εξαγωγή του pdf σε φάκελο της επιλογής μου και ταυτόχρονα να υπάρχει μία προειδοποίηση για το εάν στον ίδιο φάκελο υπάρχει ήδη αρχείο με το ίδιο όνομα.
Οι προναφερόμενοι κώδικες :
1ος αποθήκευση σε φάκελο επιλογής μας
Κώδικας:
Public Function PicFolder() As String
    Dim blnSelect As Boolean
    Dim fld As Object

    Set fld = Application.FileDialog(4)
    fld.AllowMultiSelect = False
    blnSelect = fld.Show
    If blnSelect Then
        PicFolder = fld.SelectedItems(1)
    End If
End Function

Private Sub cmdPDF_ΔελτιοΠαραγγελιας_Click()
Dim strFolder As String
    strFolder = PicFolder
    If strFolder <> "" Then
    DoCmd.OpenReport "RptΔελτία παραγγελίας", acViewPreview, ,
      "[ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ]=" & "'" & [ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ] & "'"
   
    DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF,
    strFolder & "\" & CStr(ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ) & "_Σύνολο Παραγγελιών_" & Format(Now(),
      "yyyymmdd") & ".pdf", True
    Else
        MsgBox "Δεν επιλέξατε φάκελο"
    End If
    DoCmd.Close acReport, "RptΔελτία παραγγελίας", acSaveNo
End Sub
Ο 2ος προειδοποίηση για την ύπαρξη αρχείου με το ίδιο όνομα
Κώδικας:
Private Sub Εντολή482_Click()
    Dim FileName As String

    FileName = "C:\Users\" & "ΔΠ." & CStr(ΚωδΔελτίουπαραγγελίας) & _
              "_κ.κ.." & CStr(Κείμενο218) & "_" & Format((Κείμενο194),
                  "yyyymmdd") & ".pdf"

    If Dir(FileName) <> "" Then
        If MsgBox("Το αρχείο:" & vbCrLf & FileName & vbCrLf & _
                  "Υπάρχει. Να αντικατασταθεί;", vbCritical + vbYesNo) = vbOK Then
            DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF,
              FileName, True
        End If
    Else
        DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF,
            FileName, True
    End If
End Sub
Ευχαριστώ εκ των προτέρων
Τίμος

kapetang 05-05-17 09:41
Καλημέρα

Τίμο δοκίμασε τον παρακάτω κώδικα:

Κώδικας:
Public Function PicFolder() As String
    Dim blnSelect As Boolean
    Dim fld As Object

    Set fld = Application.FileDialog(4)
    fld.AllowMultiSelect = False
    blnSelect = fld.Show
    If blnSelect Then
        PicFolder = fld.SelectedItems(1)
    End If
End Function

Private Sub cmdPDF_ΔελτιοΠαραγγελιας_Click()
    Dim strFolder As String, strFile As String
    strFolder = PicFolder
    If strFolder <> "" Then
        DoCmd.OpenReport "RptΔελτία παραγγελίας", acViewPreview, , _
                        "[ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ]=" & "'" & [ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ] & "'"

        strFile = strFolder & "\" & CStr(ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ) & "_Σύνολο Παραγγελιών_" & _
                  Format(Now(), "yyyymmdd") & ".pdf"
        Exists strFile
    Else
        MsgBox "Δεν επιλέξατε φάκελο"
    End If
    DoCmd.Close acReport, "RptΔελτία παραγγελίας", acSaveNo
End Sub

Public Sub Exists(FileName As String)
    If Dir(FileName) <> "" Then
        If MsgBox("Το αρχείο:" & vbCrLf & FileName & vbCrLf & _
                  "Υπάρχει. Να αντικατασταθεί;", vbCritical + vbYesNo) = vbYes Then
            DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF, _
              FileName, True
        End If
    Else
        DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF, _
            FileName, True
    End If
End Sub
Σημείωση: Στον κώδικα αντικαταστάθηκε η σταθερά vbOK με την vbYes

ΤΙΜΟΣ 05-05-17 12:46
Καλησπέρα Γιώργο,
Σε ευχαριστώ για την άμεση απάντηση σου. Έβαλα τους τρεις κώδικες που έστειλες στην ΒΔ αλλά κάτι γίνεται με τον τελευταίο - "Public Sub Exists" - που αναφέρεται στην αντικατάσταση του αρχείου εφόσον υπάρχει ίδιο. Εμφανίζεται το MsgBox και εάν ζητήσεις αντικατάσταση του αρχείου δεν το κάνει. Μπορείς να κάνεις κάτι για να διορθωθεί και να δουλεύει ολοκληρωμένα;
Και κάτι άλλο προς διευκρίνιση, όπως είναι γραμμένος ο κώδικας "Public Sub Exists" γίνεται εξαγωγή αρχείου pdf από την έκθεση "RptΔελτία Παραγγελίας" για κάθε προμηθευτή. Για κάθε εντολή εξαγωγής αρχείου της ίδιας λογικής, δηλ. αποθήκευση σε φάκελο επιλογής μου και ερώτηση εάν υπάρχει ήδη, θα πρέπει να γράφω εκ νέου τον κώδικα "Public Sub Exists" - σωστά;

Ευχαριστώ
Τίμος

kapetang 05-05-17 13:51
Καλησπέρα

1) Ο κώδικας, δε δοκιμάστηκε αφού δε διαθέτω τη ΒΔ.

2) Δε θα ξαναγράψεις τον κώδικα.

3) Μετά το μήνυμα πρόσθεσε τον κώδικα: Kill FileName και ξαναδοκίμασε.

Κανονικά πρέπει να διαγράφεται το παλιό αρχείο και να αποθηκεύεται το νέο.

4) Ο φάκελος στον οποίο αποθηκεύεται το αρχείο θα πρέπει να επιτρέπει αλλαγές

kapetang 05-05-17 14:07
Τώρα το είδα άλλαξε το vbOk με το vbYes

ΤΙΜΟΣ 05-05-17 17:00
Γιώργο,
Τελικά μετά από αρκετές δοκιμές ανακάλυψα πως έχει πρόβλημα ο κώδικας που παραθέτω. Μου τον έστειλες σε προηγούμενο θέμα που είχα ζητήσει βοήθεια και παρόλου που απάντησα ότι δουλεύει, αλλά λόγω φόρτου εργασίας δεν είχα παρατηρήσει ότι δεν κάνει αντικατάσταση του αρχείου. Σήμερα το πρόσεξα από την ώρα στην ημερομηνία τροποποίησης του αρχείου στις ιδιότητες, παραμένει η αρχική και δεν αλλάζει εκτελώντας την εντολή κατά την διάρκεια της ίδιας μέρας.
Εάν μπορείς να βοηθήσεις θα ήταν χρήσιμο.

Κώδικας:
Private Sub Εντολή482_Click()
    Dim FileName As String
    FileName = "C:\Users\" & "ΔΠ." & CStr(ΚωδΔελτίουπαραγγελίας) & _
                "_κ.κ.." & CStr(Κείμενο218) & "_" & Format((Κείμενο194),_
                "yyyymmdd") & ".pdf"

    DoCmd.OpenReport "RptΔελτία παραγγελίας", acViewPreview, , _
                    "[ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ]=" & "'" & [ΟΝΟΜΑ_ΠΡΟΜΗΘΕΥΤΗ] & "'"

    If Dir(FileName) <> "" Then
        If MsgBox("Το αρχείο:" & vbCrLf & FileName & vbCrLf & _
                  "Υπάρχει. Να αντικατασταθεί;", vbCritical + vbYesNo) = vbOK Then
            DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF, _
              FileName, True
        End If
    Else
          DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF, _
            FileName, True
    End If
          DoCmd.Close acReport, "RptΔελτία παραγγελίας", acSaveNo
End Sub
Ευχαριστώ εκ των προτέρων
Τίμος

ΤΙΜΟΣ 05-05-17 17:10
Καλησπέρα γιώργο,
Και εγώ μόλις έστειλα την τελευταία ανάρτηση είδα την απάντηση σου :
Παράθεση:
Τώρα το είδα άλλαξε το vbOk με το vbYes
Έκανα την αντικατάσταση και τώρα δουλεύει, οπότε αγνόησε την τελευταία μου ανάρτηση.
Θα κάνω και τις αλλαγές στους προηγούμενους κώδικες και θα επανέλθω με απάντηση.

Ευχαριστώ για τον χρόνο σου

Τίμος

ΤΙΜΟΣ 05-05-17 17:26
Γιώργο,
Κάνοντας αντικατάσταση του vbOk με το vbYes δουλεύει τώρα και η εντολή με τον συνδιασμό των τριών κωδικών. Κάτι τελευταίο για να κλείσει το θέμα, το "Kill FileName" σε ποιο σημείο του κώδικα Public Sub Exists θα πρέπει να το προσθέσω ώστε να είναι εφαρμόσιμος και σε άλλες εντολές.

Κώδικας:
Public Sub Exists(FileName As String)
    If Dir(FileName) <> "" Then
        If MsgBox("Το αρχείο:" & vbCrLf & FileName & vbCrLf & _
                  "Υπάρχει. Να αντικατασταθεί;", vbCritical + vbYesNo) = vbOK Then
            DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF, _
              FileName, True
        End If
    Else
        DoCmd.OutputTo acOutputReport, "RptΔελτία παραγγελίας", acFormatPDF, _
            FileName, True
    End If
End Sub
Ευχαριστώ
Τίμος

kapetang 05-05-17 18:06
Αφού δουλεύει δε χρειάζεται να προστεθεί η εντολή Kill.


Η ώρα είναι 02:57.

Ms-Office.gr - ©2000 - 2026, Jelsoft Enterprises Ltd.


Search Engine Optimization by vBSEO 3.3.2