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

[alex]

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

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

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

[Meteora]

Καλησπέρα

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

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]

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

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

[alex]

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

Καλημέρα

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

Για δες το...

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

[alex]

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

[alex]

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

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

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

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

[alex]

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

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

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

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