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

Σελίδα 1 από 2

Εμφάνιση 40 μηνυμάτων αυτού του θέματος σε μία σελίδα

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)

alex	23-09-13 22:23

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

Καλησπέρα σε όλους τους φίλους του 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

alex	24-09-13 06:13

1 Συνημμένο(α)

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

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

Meteora

24-09-13 20:40

Καλησπέρα

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

Κώδικας:

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 θα έγραφα κάτι για να δώ αν η μέρα είναι "εργάσιμη" ή όχι, λαμβάνοντας δεδομένα από πίνακα που θα ανανεώνεται κάθε πότε; Από ποιόν; Αυτό είναι αδύνατο σημείο στη σχεδίασή σου. Σκέψου κάτι διαφορετικό π.χ. να βγαίνει το μήνυμα, μέχρι να το χειριστείς, αποθηκεύοντας κάπου τον χειρισμό αυτό... Αν με καθήσει καμιά ιδέα θα γράψω...

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

alex	24-09-13 21:41

1 Συνημμένο(α)

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

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

alex	24-09-13 23:17

Νίκο καλησπέρα!!!
Έχω κάνει κάποιες αλλαγές .Θέλει δοκιμές και να γυρίζω την ημερομηνία του υπολογιστή η κάθε 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

Meteora

25-09-13 04:30

Καλημέρα

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

Για δες το...

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

alex	25-09-13 05:24

1 Συνημμένο(α)

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

alex	25-09-13 07:46

1 Συνημμένο(α)

Νίκο συγνώμη είχα ανεβάσει λάθος συνημμένο!!!
οπότε το άλλαξα
Δές το συνημμένο μια διαφορετική προσέγγιση.Δεν το έχω δοκιμάσει
Για να λειτουργεί όλο το πακέτο του 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

Meteora

25-09-13 17:07

1 Συνημμένο(α)

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

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

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

alex	26-09-13 11:40

1 Συνημμένο(α)

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

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

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

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

Η ώρα είναι 22:09.

Σελίδα 1 από 2

Εμφάνιση 40 μηνυμάτων αυτού του θέματος σε μία σελίδα

Search Engine Optimization by vBSEO 3.3.2