Forum - Διόρθωση-αλλαγή σε κώδικα ρουτίνας

Forum (https://www.ms-office.gr/forum/)

- Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)

- - Διόρθωση-αλλαγή σε κώδικα ρουτίνας (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/2698-diorthosi-allagi-se-kodika-roytinas.html)

Διόρθωση-αλλαγή σε κώδικα ρουτίνας

Καλησπέρα σε όλους τους φίλους του Forum!!

Γνωρίζει κάποιο μέλος στον παρακάτω κώδικα τι διόρθωση ή τι κώδικα πρέπει να βάλω ώστε να εμφανίζω το αποτέλεσμα χωρίς δεδομένα από πίνακα που εμφανίζει η παρακάτω ρουτίνα.θέλω να αποφύγω τον πίνακα και την χειροκίνητη ενημέρωση.
Το ζητούμενο είναι : 1) ότι κάθε 1 και 15 του μήνα να μου ανοίγει η ιστοσελίδα που περιέχει η ρουτίνα.
2) Εάν η ημερομηνία πέφτει Σάββατο η ενημέρωση να γίνεται δύο μέρες μετά εάν πέφτει Κυριακή να γίνεται μία μέρα μετά.
3) Τον Ιούλιο και Αύγουστο να μην ενημερώνει.

Κώδικας:

Option Compare Database

Option Explicit
 

'Ρουτίνες που ενεργοποιούνται με την έναρξη της εφαρμογής

Private Const CnstNameTable As String = "TblSurveyDays"
 

Public Sub sShowSurveyDays()

'Ρουτίνα που εμφανίζει το σύστημα καταγραφής

Dim ie As Object

'Dim ie As InternetExplorer

Dim CurrentSysDate As Date, CurrentSysMonth, CurrentSysDay As Integer

Dim i As Integer, TmpName As String

CurrentSysDate = Date

CurrentSysMonth = Month(CurrentSysDate)

CurrentSysDay = Day(CurrentSysDate)

i = 0

Dim RcdNames As New ADODB.Recordset

    RcdNames.Open "Select * From " & CnstNameTable & " Where Day=" & CurrentSysDay _

    & " and Month=" & CurrentSysMonth, CurrentProject.Connection, adOpenDynamic

    If Not RcdNames.EOF And Not RcdNames.BOF Then

        RcdNames.MoveFirst

            Do While Not RcdNames.EOF

            i = i + 1

                If i > 1 Then

                    TmpName = TmpName & " , " & RcdNames.Fields("SurveyDay")

                Else

                    TmpName = RcdNames.Fields("SurveyDay")

                End If

                RcdNames.MoveNext

            Loop

            Dim Response As Integer

            If i > 1 Then

             

           Else

                Response = MsgBox("ΚΑΛΗΜΕΡΑ ΣΗΜΕΡΑ ΠΡΕΠΕΙ ΝΑ ΕΝΗΜΕΡΩΣΕΤΕ ΤΟ : " & TmpName _

                & vbNewLine & "ΣΥΝΔΕΘΕΙΤΕ ΣΤΟ ΙΝΤΕΡΝΕΤ. ", vbYesNo + vbDefaultButton1, " ΕΝΗΜΕΡΩΣΗ ΤΟΥ SURVEY ")

            End If

            If Response = vbYes Then

               

    Set ie = CreateObject("InternetExplorer.Application")
 

    

    ie.Navigate2 "http://survey.sch.gr/"

   

    

    ie.Visible = True
 

    '
 

    While ie.ReadyState <> 4

        DoEvents

    Wend
 

    

    Set ie = Nothing
 

            End If

    End If

    RcdNames.Close

End Sub

Καλημέρα και πάλι σε όλουs τους φίλους του forum!!!

Έχω προσθέσει κάποιο κώδικα στην ρουτίνα BasExecSurveyDays που επισυνάπτω για να βελτιώσω την βοήθεια στον κώδικα.
Εάν γνωρίζει κάποιο μέλος τι πρέπει να κάνω και πώς πρέπει να συντάξω κώδικα συμφωνα με τις αργίες που εμφανίζω στη παρακάτω επισυναπτόμενη βάση.

Καλησπέρα

Δοκίμασε τον κώδικα και αν δουλέψει να τον χρησιμοποιήσω και εγώ!

Κώδικας:

Private Sub btn_start_Click()
 

If Month(Date) = 7 Or Month(Date) = 8 Then Exit Sub  'Διώχνεις Ιούλιο-Αύγουστο
 

  Dim x As Integer

  x = 1

  

  Select Case DatePart("w", Date)

  Case Is = 1                   'Κυριακή

     x = x + 1

  Case Is = 7                   'Σάββατο

     x = x + 2

  End Select

    

    If Day(Date) = x Or Day(Date) = 14 + x Then

      Dim strUrl$

      strUrl = "http://survey.sch.gr/"

      Call Shell("explorer.exe " & strUrl, 5)

    End If
 

End Sub

Εκεί ανάμεσα στη End select στην if Day(date)=x θα έγραφα κάτι για να δώ αν η μέρα είναι "εργάσιμη" ή όχι, λαμβάνοντας δεδομένα από πίνακα που θα ανανεώνεται κάθε πότε; Από ποιόν; Αυτό είναι αδύνατο σημείο στη σχεδίασή σου. Σκέψου κάτι διαφορετικό π.χ. να βγαίνει το μήνυμα, μέχρι να το χειριστείς, αποθηκεύοντας κάπου τον χειρισμό αυτό... Αν με καθήσει καμιά ιδέα θα γράψω...

Με εκτίμηση
Νίκος Δ.

Ευχαριστώ Νίκο!!!!

Θα κάνω κάποιες δοκιμές αν μπορέσω να κάνω κάτι.Με πίνακα το έχω και δουλεύει αλλά πρέπει να κοιτάξω το ημερολόγιο για τα επόμενα 5 χρόνια και να βάλω τις ημερομηνίες που πρέπει να ενημερώνουμε.
Η λογική μου είναι ότι αν γίνει με κώδικα module δεν χρειάζεται ούτε πίνακας τίποτα.
Θα το έβαζα σε ένα setup και με την εγκατάσταση θα το έβαζα στο start up με το άνοιγμα του υπολογιστή θα με ειδοποιούσε να ξεφύγουμε από αυτή την γάγγραινα.
Στο συνημμένο που ανεβάζω δουλεύει μέχρι 31/12/2003.
Απλά έβαλα την σημερινή ημερομηνία για να σου ανοίξει.Γιατί μετά τις 12 δεν θα ανοίγει ο Internet explorer.

Νίκο καλησπέρα!!!
Έχω κάνει κάποιες αλλαγές .Θέλει δοκιμές και να γυρίζω την ημερομηνία του υπολογιστή η κάθε 1η ή κάθε 15η.Προσπαθούμε!!!
Βγάζει μήνυμα Type Mismatch στη θέση If Month(Date) = 7 Or Month(Date) = 8 Then Exit Sub *''Διώχνεις Ιούλιο και Αύγουστο
* **

Κώδικας:

 

Public Sub sShowSurveyDays()

    'Η ρουτίνα που εμφανίζει το σύστημα καταγραφής των στοιχείων

    Dim ie As Object

    Dim Month As Variant

    Dim TmpName As String

'Εδώ χτυπάει

    If Month(Date) = 7 Or Month(Date) = 8 Then Exit Sub  'Διώχνεις Ιούλιο και Αύγουστο

    

    Dim x As Integer

    x = 1

    

    Select Case DatePart("w", Date)

    Case Is = 1                   'Κυριακή

       x = x + 1

    Case Is = 7                   'Σάββατο

       x = x + 2

    End Select

      

      If Day(Date) = x Or Day(Date) = 14 + x Then

    

    Dim Response As Integer

            

      Response = MsgBox("ΚΑΛΗΜΕΡΑ ΣΗΜΕΡΑ ΠΡΕΠΕΙ ΝΑ ΕΝΗΜΕΡΩΣΕΤΕ ΤΟ  : " & TmpName _

                & vbNewLine &"ΣΥΝΔΕΘΕΙΤΕ ΣΤΟ ΙΝΤΕΡΝΕΤ. ", vbYesNo + vbDefaultButton1, " ΕΝΗΜΕΡΩΣΗ ΤΟΥ SURVEY ")

             

              If Response = vbYes Then

    

      Set ie = CreateObject("InternetExplorer.Application")

    

    

      ie.Navigate2 "http://survey.sch.gr/"

    

    

      ie.Visible = True

    

    End If

       End If

    End Sub

Καλημέρα

Χτυπάει γιατί η έκφραση Month(ημερονία) είναι συνάρτηση που επιστρέφει τον μήνα της ημερομηνίας του ορίσματος και εσύ όρισες τη λέξη Month ως μεταβλητή!
Διέγραψε το : Dim Month As Variant

Για δες το...

με εκτίμηση, Νίκος Δ.

Καλημέρα Νίκο!!
Σωστά το διόρθωσα δεν κτυπάει αλλά δεν δουλεύει.Πρέπει να περπατήσω το κώδικα γραμμή γραμμή κάπου πρέπει να πηδάει σειρές.

Νίκο συγνώμη είχα ανεβάσει λάθος συνημμένο!!!
οπότε το άλλαξα
Δές το συνημμένο μια διαφορετική προσέγγιση.Δεν το έχω δοκιμάσει
Για να λειτουργεί όλο το πακέτο του Module να βρίσκει το έτος το ανάλογο πάσχα τα ΣΚ off μέχρι εκεί δουλεύει
Η αλλαγή στο κώδικα που έκανα .
Θέλει συμπλήρωμα κώδικα που να λέει εάν συμπίπτουν οι ημερομηνίες 1 και 15 κάθε μήνα με τα weekends να μεταφέρονται οι ημερομηνίες από το Σάββατο +2 και την Κυριακή +1 και να εμφανίζει το παρακάτω μήνυμα με πράσινο από εκεί και κάτω πάλι δουλεύει.

Κώδικας:

Public Sub sShowSurveyDays()

'Η ρουτίνα που εμφανίζει το σύστημα καταγραφής των στοιχείων

 Dim ie As Object

 Dim TmpName As String

 Dim StartDate As Date

 Dim NettoAbsenceDays As Integer

 Dim LastAbsenceDate As Date

 Dim i As Integer, xDate As Date

 Dim EndDate As Date

    For xDate = StartDate To EndDate

        If Weekday(xDate, vbMonday) < 5 Then

            If Not IsHoliday(xDate) Then

                CountOfWDays = CountOfWDays + 1

                Else

                HolidaysCount = HolidaysCount + 1

            End If

        End If

    Next

 Dim Response As Integer

  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'χχχχχχχχχχχχχχχχχχχχχχχχχχχχχχχ

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''       

   Response = MsgBox("ΚΑΛΗΜΕΡΑ ΣΗΜΕΡΑ ΠΡΕΠΕΙ ΝΑ ΕΝΗΜΕΡΩΣΕΤΕ ΤΟ  : " & TmpName _

                & vbNewLine &"ΣΥΝΔΕΘΕΙΤΕ ΣΤΟ ΙΝΤΕΡΝΕΤ. ", vbYesNo + vbDefaultButton1, " ΕΝΗΜΕΡΩΣΗ ΤΟΥ SURVEY ")

          

           If Response = vbYes Then

 

   Set ie = CreateObject("InternetExplorer.Application")

 

 

   ie.Navigate2 "http://survey.sch.gr/"

 

 

   ie.Visible = True

 

  End If

   

 

 End Sub

Καλησπέρα
Δεν συμφωνώ με την επιλογή σου να ψάχνεις τις μη εργάσιμες ημέρες για το θέμα που συζητάμε. Παράδειγμα: Είναι Παρασκευή 1-xx-2013 και εσύ ο χειριστής απουσιάζεις. Αυτό σημαίνει ότι ...τη Δευτέρα "το πουλάκι πέταξε"! Άρα πάει στράφι όλη η δουλειά σου για να οργανώσεις πίνακες με Πάσχα, Χριστούγεννα, κλπ. Έχω κάτι "θολό" στον νου μου αλλά δεν μπορώ να το δώ πριν το Σαββατοκύριακο.
Προς το παρόν -ενσωμάτωσα σε μικροεφαρμογές που χρησιμοποιώ στο σχολείο, τον κώδικα του επισυναπτόμενου. Ειλικρινά δεν μπόρεσα να δοκιμάσω το δικό σου λόγω χρόνου.

Μόλις έχω κάνει σχετικό με αυτό που σκέπτομαι, θα τα ξαναπούμε

Με εκτίμηση
Νίκος Δ.

Καλημέρα στη παρέα!!!!
Καλημέρα Νίκο!!
Συγνώμη από το Διαχειριστή για κάποιες διορθώσεις.

Τελικά έκανα μετά από μεγάλο κόπο έστω προσωρινά Manual όλα αυτά που χρειάζονται για την ενημέρωση του Survey.Επόμενο βήμα προγραμματιστικά.

Τί κάνει το πρόγραμμα:
1) Κάθε 1 και 15 του μήνα ανοίγει η ιστοσελίδα που περιέχει η ρουτίνα.
2) Εάν η ημερομηνία πέφτει Σάββατο η ενημέρωση να γίνεται δύο μέρες μετά εάν πέφτει Κυριακή γίνεται μία μέρα μετά.
3)Εάν είναι περίοδος Χριστουγέννων ενημερώνει με τη έναρξη του πρώτου μαθήματος
Εάν είναι Πάσχα σύμφωνα με το Πατριαρχείο κάθε χρόνο μεταβαλλόμενες ημερομηνίες με την αμέσως επόμενη εργάσιμη ημέρα
4) Τον Ιούλιο και Αύγουστο να μην ενημερώνει.

Υ/Γ Ενημέρωση κάνει μέχρι το 2030

Καλημέρα στη παρέα!
Καλημέρα σε όλους τους φίλους του Forum.
Στο παρακάτω και στοιχισμένο κώδικα έχω φθάσει προγραμματιστικά και με την βοήθεια του Νίκου να δουλεύει το module εκτός από 2 γραμμές κώδικα που δεν κατάφερα που είναι σημειωμένες με κόκκινο.
Το module εντοπίζει τις αργίες και δεν ενημερώνει με μήνυμα όπως και αυτό θέλουμε.
Εντοπίζει τα σαββατοκύριακα και δεν ενημερώνει με μήνυμα όπως και πάλι θέλουμε .
Ενημερώνει κάθε 1 και 15 όπως και θέλουμε.
Το έχω δοκιμάσει τρέχοντας τον κώδικα αλλά "Σκάλωσα"στα κόκκινα.
Μπορεί να το δοκιμάσει κάποιο έμπειρο μέλος το module : BasExecSurveyDays έστω να μου πει τι να κάνω;Πρέπει όμως να τρέξει το κώδικα step by step και σύμφωνα με την ημερομηνία του Η/Υ να δει την διαδρομή μέχρι τα κόκκινα.Στα κόκκινα δίνεται επεξήγηση το τι κάνει και τι πρέπει να γίνει.
Παραθέτω τον κώδικα σε συνημμένο αφού κατέβαλα μεγάλες προσπάθειες.

Κώδικας:

Public Sub sShowSurveyDays()

'Η ρουτίνα που εμφανίζει το σύστημα καταγραφής των στοιχείων

    Dim ie As Object

    Dim TmpName As String

    Dim StartDate As Date

    Dim xDate As Date

    Dim EndDate As Date

    Dim CountOfWDays As Integer

    Dim x As Integer

    Dim KiriakiTouPasxa As Date

    Dim Response As Integer

    Dim theDate As Date

    If Month(Date) = 7 Or Month(Date) = 8 Then Exit Sub       'Διώχνει Ιούλιο και Αύγουστο

    x = 1

    For xDate = StartDate To EndDate

        If Weekday(Date, vbSunday) Then

            If Not IsHoliday(Date) Then

                CountOfWDays = CountOfWDays + 1

            Else

                If IsHoliday(Date) Then

                    HolidaysCount = HolidaysCount + 1

                End If

            End If

        End If

    Next

    Select Case DatePart("w", Date)
 

    Case Is = 1              'Κυριακή

        x = x + 1

    Case Is = 7              'Σαββάτο

        x = x + 2

    Case Is = 2              'Δευτέρα

        x = x

    Case Is = 3              'Τρίτη

        x = x

    Case Is = 4              'Τετάρτη

        x = x

    Case Is = 5              'Πέμπτη

        x = x

    Case Is = 6              'Παρασκευή

        x = x

    End Select
 

    If IsHoliday(Date) Then

        HolidaysCount = HolidaysCount + 1

    Else

'Εδώ στην σύνταξη  για την KiriakiTouPasxa δεν γνωρίζω πώς πρέπει να το συντάξω.

        ' KiriakiTouPasxa = Day(Date)         'Θέλω να μου δίνει την επόμενη μέρα από την KiriakiTouPasxa για να μου ανοίγει το μήνυμα

        If Day(Date) = KiriakiTouPasxa + 1 Then

            'Else

            If Day(Date) = x Or Day(Date) = 14 + x Then    ' Εδώ δουλεύει η ημερομηνία εάν δεν είναι Σ/Κ κάθε 1 και 15 να ανοίξει το μήνυμα

                'Else

                'If Day(Date) = DateSerial(Etos, 1, 8) Then    'Θέλω να μου ανοίξει το μήνυμα κάθε 8 του Γενάρη.
 

                Response = MsgBox("ΚΑΛΗΜΕΡΑ ΣΗΜΕΡΑ ΠΡΕΠΕΙ ΝΑ ΕΝΗΜΕΡΩΣΕΤΕ ΤΟ ΣΥΣΤΗΜΑ ΚΑΤΑΓΡΑΦΗΣ Α/ΘΜΙΑΣ & Β/ΘΜΙΑΣ ΕΚ/ΠΣΗΣ : " & TmpName _

                                & vbNewLine & "ΣΥΝΔΕΘΕΙΤΕ ΣΤΟ INTERNET. ", vbYesNo + vbDefaultButton1, " ΕΝΗΜΕΡΩΣΗ TOY SURVEY ")
 

                If Response = vbYes Then
 

                    Set ie = CreateObject("InternetExplorer.Application")
 

                    ie.Navigate2 "http://survey.sch.gr/"
 

                    ie.Visible = True

                End If

            End If

        End If

    End If

    ' End If

End Sub