Ανανέωση ιστοσελίδας
ms-office.gr > Forum > Microsoft Access > Access - Ερωτήσεις / Απαντήσεις > Πρόβλημα με την ομαδική αποστολή SMS

Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια!

Απάντηση στο θέμα

 

Εργαλεία Θεμάτων Τρόποι εμφάνισης
  #1  
Παλιά 02-04-12, 09:57
Όνομα: Αλέξανδρος
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 22-01-2010
Περιοχή: ΑΡΤΑ
Μηνύματα: 521
Προεπιλογή Πρόβλημα με την ομαδική αποστολή SMS

Kαλήμέρα σε όλη στην κοινότητα

Στη φόρμα SMS στο κώδικα
Κώδικας:
Private Sub Εντολή9_Click()
Dim i As Variant
Dim mMessage As Variant

'Αλλαγή των κενών χαρακτήρων του μηνύματος σε %20
For i = 1 To Len(Me.Message.Value)
    If Mid(Me.Message.Value, i, 1) = " " Then
        mMessage = mMessage & "%20"
    Else
        mMessage = mMessage & Mid(Me.Message.Value, i, 1)
    End If
    
Next

SMSPost1.From = Me.From.Value   'Αποστολέας

SMSPost1.Message = mMessage   'Το κείμενο του μηνύματος

SMSPost1.username = Me.username.Value   'Όνομα εισόδου

SMSPost1.password = Me.password.Value   'Κωδικοί εισόδου

SMSPost1.sTo = Me.SMSNumber.Value    'Ο αριθμός κινητού που θα σταλεί το μήνυμα

SMSPost1.sRequestType = "POST" 'Τύπος αποστολής - ΠροεπιλεγμέναPOST - Άλλες τιμές GET

SMSPost1.SendSMS 'Έναρξη αποστολής

MsgBox SMSPost1.SMSResponse, vbInformation 'Επιστροφή απο τον SMS Warrior


End Sub
__________________________________________________________________
Private Sub CmdCheckAll_Click()
Dim strSQL As String
 Dim rst As Recordset
strSQL = "Select * From CustomersRecs Where ID = " & _
 lngID & "SMS"
Dim intRecordsChecks As Integer
    intRecordsChecks = DCount("telefon", "customers", "Check=true")

            If intRecordsChecks > 0 Then
                DoCmd.RunSQL ("UPDATE customers Set Check=0")
            Else
                DoCmd.RunSQL ("UPDATE customers Set Check=-1")
            End If
            
    Me.Check.Requery
Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
 If rst.RecordCount > 0 Then
 rst.MoveFirst
 Do While Not rst.EOF
'....process
 rst.MoveNext
Loop
 End If
End Sub
________________________________________________________________________


Public Function CountCustomerSms(IntID As Long) As Long
    CountCustomerSms = Nz(DCount("ID", "customers", "ID='" & Nz(IntID, 0) & "'"), 0)
End Function
Το σενάριο είναι το εξής .Έχω βάλει ένα Active X απο μία εταιρεία που αγοράζω μηνύματα και μου έχει δώσει ένα Username και Password.
Μπορώ να στέλνω μηνύματα ένα -ένα.Θέλω ο΄μως να στέλνω ολα μαζι με ένα checkbox που έχω βάλει για να τα επιλέγει.Το προβλημάμου είναι στο Loop για να στέλνονται όλα μαζί ή όσα έχω επιλέξει απο με τα Checkboxes.Στέλνω δείγμα της βάσης για βοήθεια.
Ευχαριστώ εκ των προτέρων για τις αλλεπάλληλες βοήθειες των μελών
Φιλικά
Αλέξανδρος
Συνημμένα Αρχεία
Τύπος Αρχείου: zip SMS.zip (456,2 KB, 59 εμφανίσεις)
Απάντηση με παράθεση
  #2  
Παλιά 04-04-12, 13:59
Όνομα: Αλέξανδρος
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 22-01-2010
Περιοχή: ΑΡΤΑ
Μηνύματα: 521
Προεπιλογή

Kαλησπέρα σε όλους τους φίλους

Εχω κάνει κάποιες αλλαγές στον παρακάτω κώδικα

Κώδικας:
Private Sub CmdCheckAll_Click()
Dim strSQL As String
Dim dbs As Database
Dim rst As Recordset
Dim Counter As Integer

Set dbs = CurrentDb
Set rst = dbs.OpenRecordset("SELECT * FROM [customers]", dbOpenDynaset)
 
Dim intRecordsChecks As Integer
    intRecordsChecks = DCount("telefon", "customers", "Check=true")

            If intRecordsChecks > 0 Then
                DoCmd.RunSQL ("UPDATE customers Set Check=0")
            Else
                DoCmd.RunSQL ("UPDATE customers Set Check=-1")
            End If
            
    Me.Check.Requery

 If rst.RecordCount > 0 Then
 rst.MoveFirst
 Do While Not rst.EOF
'....process
 rst.MoveNext
Loop
' one less record to go
Counter = Counter - 1

' start loop again
'Wend
 End If
 
End Sub
Επειδή δεν έχω τον τρόπο να το δοκιμάσω εάν δουλεύει το Loop για την ομαδική αποστολή SMS.Γνωρίζει κάποιο έμπειρο μέλος εάν είναι σωστός ο κώδικας ;

Φιλικά/Αλέξανδρος
Απάντηση με παράθεση
  #3  
Παλιά 04-04-12, 18:25
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.034
Προεπιλογή

Αλέξανδρε καλησπέρα!

Πριν από ένα χρόνο περίπου είχα προγραμματίσει πάνω στο ίδιο αντικείμενο για ένα λογιστικό γραφείο σε Access και VB.NET.

Πριν προχωρήσεις στην αυτοματοποίηση της μαζικής αποστολής SMS, θα πρέπει να ετοιμάσεις πίνακες που όπου θα καταγράφεται το ιστορικό της αποστολής ανά πελάτη.

Όταν στέλνεις ένα SMS, αρχικά ο Server θα σου πιστοποιήσει ότι το παρέλαβε (SMSPost1.SMSResponse).

Μόνο με την πληροφορία αυτή δεν μπορείς γνωρίζεις το αν και το πότε ένα μήνυμα απεστάλη στον παραλήπτη.

Κανονικά θα πρέπει να δημιουργήσεις τους κατάλληλους πίνακες όπου θα καταγράφεις:
  • Τι κείμενο έστειλες
  • Σε ποιον το έστειλες
  • Πότε το έστειλες
  • Αν παραλήφθηκε επιτυχώς.
Θα χρειαστεί να γνωρίζεις πως θα "ρωτήσεις" τον Server για τις πληροφορίες αυτές (Υποστηρίζεται από τον συγκεκριμένο Server).


Δεν θα εμβαθύνω το θέμα στο σημείο αυτό γιατί δεν είναι τόσο απλό όσο φαίνεται.

Ο παρακάτω κώδικας, μπορεί να στείλει μαζικά SMS. Το πόσα πολλά μπορεί να στείλει κάθε φορά εξαρτάται από το ίδιο το Activex.

Εγώ προσωπικά χρησιμοποίησα τον Internet Explorer αντί για το Activex χωρίς βέβαια αυτό να σημαίνει ότι το δεύτερο δεν λειτουργεί.
Απλά θέλησα να αποφύγω την εγκατάσταση του Activex στον υπολογιστή προορισμού.

Ο παραδειγματικός κώδικας προϋποθέτει τους πίνακες Customers και tblServerResponces με τα εξής πεδία:

Πίνακας Customers:
  • CustomerID (Κλειδί, Αυτόματη αρίθμηση)
  • txtMessage (υπόμνημα)
  • txtTelefon (κείμενο)
  • MessageID (αριθμός)
  • BlnCheck (Αληθές/Ψευδές)
Πίνακας tblServerResponses:

  • ResponseID (Κλειδί, Αυτόματη αρίθμηση)
  • CustomerID (αριθμός)
  • MessageID (αριθμός)
  • dtDate (Ημερομηνία)
  • txtResponse (κείμενο)
Κώδικας:
Option Compare Database
Option Explicit

Private Function GetSMSServerResponse( _
        strMessage As Integer, _
        strFrom As String, _
        strUserName As String, _
        strPassword As String, _
        strTo As String, _
        Optional strRequestType As String = "POST" _
        ) As String

    strMessage = Replace(Trim(strMessage), " ", "%20")
    Me.SMSPost1.From = strFrom
    Me.SMSPost1.Message = strMessage
    Me.SMSPost1.username = strUserName
    Me.SMSPost1.password = strPassword
    Me.SMSPost1.sTo = strTo
    Me.SMSPost1.sRequestType = strRequestType
    Me.SMSPost1.SendSMS
    GetSMSServerResponse = SMSPost1.SMSResponse

End Function
'-----------------------------------------------------------------

Private Sub cmdSendSMS_Click()
    Dim strSQL As String
    Dim rsSource As DAO.Recordset
    Dim rsResponse As DAO.Recordset
    Dim strResponse As String

    strSQL = "SELECT * FROM Customers WHERE BlnCheck=-1"
    Set rsSource = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
    If rsSource.RecordCount Then
        rsSource.MoveFirst
        strSQL = "SELECT * FROM tblServerResponses"
        Set rsResponse = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)
        While Not rsSource.EOF
            strResponse = GetSMSServerResponse( _
                          Nz(Me.txtMessage), _
                          Nz(Me.txtFrom), _
                          Nz(Me.txtUserName), _
                          Nz(Me.txtPassword), _
                          Nz(rsSource!txtTelefon))

            rsResponse.AddNew
            rsResponse!dtDate = Now
            rsResponse!CustomerID = rsSource!CustomerID
            rsResponse!txtResponse = strResponse
            rsResponse!txtMessage = Nz(Me.txtMessage)
            rsResponse.Update

            rsSource.MoveNext
        Wend

        rsSource.Close
        Set rsSource = Nothing
        rsResponse.Close
        Set rsResponse = Nothing
    Else
        MsgBox "δεν έχετε τσεκάρει κανένα παραλήπτη!", vbInformation
        rsSource.Close
        Set rsSource = Nothing
    End If
End Sub
Με αυτό τον τρόπο μπορείς να στείλεις μαζικά SMS.


Φιλικά

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών

Τελευταία επεξεργασία από το χρήστη Tasos : 05-04-12 στις 01:06.
Απάντηση με παράθεση
  #4  
Παλιά 04-04-12, 21:52
Όνομα: Αλέξανδρος
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 22-01-2010
Περιοχή: ΑΡΤΑ
Μηνύματα: 521
Προεπιλογή

Kαλησπέρα Τάσο

Κατ'αρχήν σ'ευχαριστώ για τις αλλεπάλληλες βοήθειες που έχω λάβει.
Τελικά από ότι κατάλαβα πρέπει να κάνω διαχείριση αποστολής SMS.
Τα SMS είναι μόνο εξερχόμενα δεν λαμβάνω μηνύματα.Σε μία δοκιμαστική που έκανα σε μήνυμα αποστολής ένα- ένα ο Server μου απάντησε ότι στάλθηκε επιτυχώς.Για να έχω όμως την επιβεβαίωση ως καταγραφή σε πίνακα θα πρέπει να συνεργαστώ με τον Server.Έτσι δεν είναι;Αυτό βέβαια είναι πολύπλοκο όπως και αναφέρεις.Το καλό είναι ότι με τον Ιnternet Explorer εξαρτάσαι μερικώς από την εταιρεία και δεν είσαι υποχρεωμένος να εγκαταστήσειςActive X Dll με επωνυμία Εταιρείας και το σπουδαιότερο δεν θα βγάζει λογότυπο της εταιρείας, θέλω να πιστεύω.
Τώρα εάν χρησιμοποιήσω τον δικό σου κώδικα θα φτιάξω τους δύο πίνακες.
και την φόρμα όπως έχει;Δεν θα έχω λες πρόβλημα;
Την άλλη εβδομάδα θα αγοράσω 1000 μηνύματα και θα το δοκιμάσω με τον δικό σου τρόπο. Εάν δεν στέλνει τότε έχω την δική μου επιλογή να χρησιμοποιήσω το Active Χ .
Αφού με επιβεβαίωσες ότι το έχω σωστά το Loop τουλάχιστον και στέλνει μαζικά
__________________________________________________ ___-
Να σε ρωτήσω και κάτι άλλο καμία σχέση με το αντικείμενο που συζητήσαμε.
Στη βάση αυτή πρόσθεσα στη φόρμα SMS ένα κουμπί εντολής για backGround και έφτιαξα μια δική μου παλέτα χειροποίητα με χρώματα να αλλάζει το φόντο της βάσης.Επειδή όμως παιδεύτικα πάρα πολύ και έκανα και λάθος σε μερικά χρώματα θα ήθελα να ρωτήσω.Το ερώτημα είναι:
Πώς μπορώ να ανοίξω την παλέτα των χρωμάτων της ζωγραφικής για να αλλάζω προγραμματιστικά το φόντο κάποιας φόρμας και όχι της βάσης;
Ίσως χρειαστεί να μεταφερθεί το θέμα.
Στέλνω μια βάση να δείς τι έχω κάνει(με λίγα Βytes γιατί δεν την φορτώνει αυτή που χρησιμοποίσα) και αν υπάρχει η δυνατότητα αυτή που περιέγραψα.

Φιλικά
Αλέξανδρος
Συνημμένα Αρχεία
Τύπος Αρχείου: zip Allagi_Font.zip (258,0 KB, 52 εμφανίσεις)
Απάντηση με παράθεση
  #5  
Παλιά 05-04-12, 00:56
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.034
Προεπιλογή

Καλησπέρα Αλέξανδρε!
Όταν ο Server, με τη χρήση του SMSPost1.SMSResponse σου επιστρέφει "delivered", εννοεί ότι το μήνυμα σου προς τον Server στάλθηκε επιτυχώς.
Όχι το μήνυμα σου προς τον παραλήπτη.

Oι πιθανές ανταποκρίσεις του Server είναι:
  • "delivered"
  • "sent"
  • "pending"
  • "failed"
  • "expired"
  • "rejected"

Για να επιλέξεις χρώμα από την παλέτα των χρωμάτων της ζωγραφικής στην Access χρησιμοποίησε:

Κώδικας:
Private Declare Sub ChooseColor Lib "msaccess.exe" Alias "#53" ( _
                                ByVal Hwnd As Long, lngColor As Long)

Private Sub cmdSetBackColor_Click()
    Dim cColor As Long
    cColor = Me.Section(0).BackColor
    ChooseColor Me.Hwnd, cColor
    Me.Section(0).BackColor = cColor
End Sub
Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών
Απάντηση με παράθεση
  #6  
Παλιά 05-04-12, 07:41
Όνομα: Αλέξανδρος
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 22-01-2010
Περιοχή: ΑΡΤΑ
Μηνύματα: 521
Προεπιλογή

Καλημέρα Τάσο

Ευχαριστώ πολύ για όλα.θα τα δοκιμάσω με την παραλαβή των μηνυμάτων θα ενημερώσω για την λειτουργία των SMS

Φιλικά
Αλέξανδρος
Απάντηση με παράθεση
  #7  
Παλιά 02-05-12, 11:47
Όνομα: Αλέξανδρος
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 22-01-2010
Περιοχή: ΑΡΤΑ
Μηνύματα: 521
Προεπιλογή

Καλημέρα στην κοινότητα, καλό μήνα σε όλους
Καλημέρα Τάσο
Μη αφήνοντας σε εκκρεμότητα τα λεγόμενα μου με την διεκπεραίωση της εφαρμογής SMS οφείλω χρέος ενημέρωσης του αντικειμένου.
Τελικά κατέληξα κατά κάποιο τρόπο στο ότι χρειάζομαι συνεργασία με κάποια εταιρεία για να στείλω μαζικά (SMS).
Από όνομα χρήστη,κωδικό,μέχρι τέλος στη προπληρωμή μηνυμάτων.
Χρησιμοποίησα το API που δίνουν όλες οι εταιρείες είτε είναι σε asp ή php to Website βάζοντας ένα πεδίο (webtxt).
Χρησιμοποίησα ένα reference ΧΜL ,και create object για τις ιδιότητες.
Έτσι όταν η βάση σου είναι κλειδωμένη έχει την ευεληξία κινήσεων αλλαγής εταιρείας.
Δεν κατάφερα με το τρόπο που μου έγραψες (InternetExplorer)να στο προσαρμόσω να στείλω μήνυμα.
Έτσι βρίσκοντας το οικονομικό πακέτο κάποιας εταιρείας βάζεις το αντίστοιχο website που σου δίνει η εκάστοτε εταιρεία είτε είναι asp είτε php ,βγάζεις και τα :Username, password της συγκεκριμένης εταιρείας.
Έφτιαξα και ένα δεύτερο πεδίο webtxt1 όπου βάζοντας ένα url για credit μου επιστρέφει την τιμή του υπολοίπου ex.Credit:0.00

Έχω όμως μια ερώτηση το μήνυμα της access που επιστρέφει την τιμή πχ. Credit:0.00 ή ότι άλλοΠχ.όταν το μήνυμα σταλεί μου επιστρέφει ΠΧ.Μid 000E83 που σημαίνει ότι το μήνυμα στάλθηκε .
Πώς μπορώ να το περάσω σε πίνακα για αποθήκευση;
Αν και πιστεύω καλύτερα είναι η αποθήκευση εκτός βάσης για το θέμα υπερφόρτωσης(όγκου).
Απλά ΄δεν χρησιμοποίησα στην μαζική αποστολή το check box αλλά με κώδικα μετέφερα τα επιλεγμένα κινητά τηλέφωνα σε πεδίο (txtTo)που ορίζετε απο την εταιρεία με την ίδια ονομασία.
Ο κωδικας που χρησιμοποίησα για την αποστολή είναι ο εξής¨:

Κώδικας:
Public Function WinHTTPPostRequest(url As String, FormData As String) As String
    Dim http As New MSXML2.XMLHTTP
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url & "?" & FormData, False
    http.setRequestHeader "Content-Type", "multipart/form-data; "
    http.send FormData
    WinHTTPPostRequest = http.responseText
End Function
Public Function URLEncode(ByVal StringToEncode As String) As String
   
   If StringToEncode = "" Then
        URLEncode = ""
        Exit Function
   End If
   
   Dim i                As Integer
   Dim iAsc             As Long
   Dim sTemp            As String
   
   Dim ByteArrayToEncode() As Byte
 
   ByteArrayToEncode = ADO_EncodeUTF8(StringToEncode)
   
   For i = 0 To UBound(ByteArrayToEncode)
      iAsc = ByteArrayToEncode(i)
      Select Case iAsc
         Case 32 'space
            sTemp = "+"
         Case 48 To 57, 65 To 90, 97 To 122
            sTemp = Chr(ByteArrayToEncode(i))
         Case Else
            'Debug.Print iAsc
            sTemp = "%" & Hex(iAsc)
      End Select
      URLEncode = URLEncode & sTemp
   Next
   
   
 
End Function
'Purpose: UTF16 to UTF8 using ADO
Public Function ADO_EncodeUTF8(ByVal strUTF16 As String) As Byte()
 
   Const adTypeBinary As Long = 1
   Const adTypeText As Long = 2
   Const adModeReadWrite As Long = 3
 
   Dim objStream        As Object
   Dim data()           As Byte
 
   If strUTF16 = "" Then
      ADO_EncodeUTF8 = data
      Exit Function
   End If
 
   Set objStream = CreateObject("ADODB.Stream")
   objStream.CharSet = "utf-8"
   objStream.Mode = adModeReadWrite
   objStream.Type = adTypeText
   objStream.Open
   objStream.WriteText strUTF16
   objStream.flush
   objStream.Position = 0
   objStream.Type = adTypeBinary
   objStream.Read 3 ' skip BOM
   data = objStream.Read()
   objStream.Close
   ADO_EncodeUTF8 = data
 
End Function
Private Sub btn2SendSMS_Click()
 
    'Dim data As String
    
   ' data = "username=" & Nz(Me.txtUsername) & _
   '        "&password=" & Nz(Me.txtPassword) & _
   '        "&from=" & Nz(Me.txtFrom) & _
   '        "&to=" & Nz(Me.txtTo) & _
    '       "&message=" & URLEncode(Nz(Me.txtMessage))
    
   ' Dim result As String
    
  '  result = WinHTTPPostRequest(Me.txtWebsite3, data)
    
  '  MsgBox result
    
End Sub
Private Sub btn3SendSMS_Click()

'    Dim data As String
    
 '   data = "username=" & Nz(Me.txtUsername) & _
 '          "&password=" & Nz(Me.txtPassword) & _
'           "&from=" & Nz(Me.txtFrom) & _
 '          "&to=" & Nz(Me.txtTo) & _
 '          "&message=" & URLEncode(Nz(Me.txtMessage))
    
 '   Dim result As String
    
 '   result = WinHTTPPostRequest(Me.txtWebsite4, data)
    
 '   MsgBox result
End Sub
Private Sub btn4SendSMS_Click()

'    Dim data As String
    
'    data = "username=" & Nz(Me.txtUsername) & _
'           "&password=" & Nz(Me.txtPassword) & _
'           "&from=" & Nz(Me.txtFrom) & _
'           "&to=" & Nz(Me.txtTo) & _
'           "&message=" & URLEncode(Nz(Me.txtMessage))
    
'    Dim result As String
    
'    result = WinHTTPPostRequest(Me.txtWebsite5, data)
    
'    MsgBox result
End Sub

Private Sub btnSendSMS_Click()

   
    Dim data As String
  
  
    data = "username=" & Nz(Me.txtUsername) & _
           "&password=" & Nz(Me.txtPassword) & _
           "&from=" & Nz(Me.txtFrom) & _
           "&to=" & Nz(Me.txtTo) & _
           "&message=" & URLEncode(Nz(Me.txtMessage))
    Dim pp As Variant, p As Variant, i As Long, cnt As Long
     
       DoCmd.SetWarnings False
            pp = Split(txtTo, ",")
      If txtTo = "" Then
        MsgBox ("Συμπληρώστε υποχρεωτικά και τα 3 πεδία που είναι μαρκαρισμένα με αστεράκι)
        Else
            cnt = UBound(pp) + 1
        If MsgBox("Έχετε επιλέξει " & cnt & " παραλήπτες." & vbNewLine & "¸έναρξη αποστολής ", _
            vbQuestion + vbOKCancel + vbDefaultButton2, "Αποστολή πολαπλών μηνυμάτων(SMS)") <> vbOK Then Exit Sub
        
      
        
    Dim result As String
    
    result = WinHTTPPostRequest(Me.txtWebsite, data)
    
    MsgBox result
    
   End If

End Sub
Private Sub btn1SendSMS_Click()

   
    Dim data As String
    
    data = "username=" & Nz(Me.txtUsername) & _
           "&password=" & Nz(Me.txtPassword) & _
           "&from=" & Nz(Me.txtFrom) & _
           "&to=" & Nz(Me.txtTo) & _
           "&message=" & URLEncode(Nz(Me.txtMessage))
    
    Dim result As String
    
    result = WinHTTPPostRequest(Me.txtWebsite2, data)
    
    MsgBox result
    
    

End Sub
Φιλικά/Αλέξανδρος
Απάντηση με παράθεση
  #8  
Παλιά 02-05-12, 13:31
Το avatar του χρήστη Tasos
Διαχειριστής
Όνομα: Τάσος Φιλοξενιδης
Έκδοση λογισμικού Office: Ms-Office 365
Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική
 
Εγγραφή: 21-10-2009
Μηνύματα: 2.034
Προεπιλογή

Καλησπέρα!
Αλέξανδρε, αντικατέστησε στον κώδικα σου το

MsgBox result
με
Me.Pedio = result

Πάντως... πολύ φασαρία φίλε μου ο κώδικας αυτός.... Σε μαζικές αποστολές είσαι σίγουρος ότι συμπεριφέρεται σωστά; Αν στείλεις απανωτά 2-3 SMS στο ίδιο νούμερο λειτουργεί κανονικά;

Το Μid 000E83 είναι το ID που δίνει ο Server αφού παραλάβει τα δεδομένα από την εφαρμογή σου επιτυχώς και φυσικά θα το χρειαστείς (εξηγείται παρακάτω).

Αυτός ο αριθμός δεν σημαίνει ότι το μήνυμα έχει φτάσει στον τελικό παραλήπτη.

Θα πρέπει αφού κάνεις την αποστολή, να κάνεις ερώτημα στον Server (πάλι με χρήση URL και του Μid 000E83 ) αν τα μηνύματα έχουν πια παραληφθεί από τον τελικό παραλήπτη αν θέλεις να κάνεις σωστή δουλειά.

Για να το κάνεις με Internet Explorer (εφόσον υποστηρίζεται από τον διακομιστή SMS)
μπορείς να πειραματιστείς με τον παρακάτω κώδικα:


Κώδικας:
'Created by Tasos Filoxenidis
Public Function SendSMS(strSmsNumber As String, _
                        strMessage As String, _
                        strSenderName As String, _
                        strPassword As String, _
                        strUsername As String) As String
    Const DoNotRememberMe = 14&
    Dim MyUrl As String
    MyUrl = "http://www.Provider.gr/sms/Service.asp?userid=" & strUsername & _
            "&password=" & strPassword & "&from=" & strSenderName & "&message=" & strMessage & _
            "&to=" & strSmsNumber & "&rid=" & strUsername

    Set ie = CreateObject("InternetExplorer.Application")
    ie.Navigate2 MyUrl, DoNotRememberMe
    While ie.readyState <> READYSTATE_COMPLETE
        DoEvents
    Wend
    SendSMS = ie.Document.body.innerhtml
    ie.ExecWB OLECMDID_CLOSE, OLECMDEXECOPT_DONTPROMPTUSER, 0, 0
    Set ie = Nothing
End Function
Καλή συνέχεια!

Τάσος
__________________
Ms-Office Development Team
Ανάπτυξη επαγγελματικών εφαρμογών

Τελευταία επεξεργασία από το χρήστη Tasos : 02-05-12 στις 13:42.
Απάντηση με παράθεση
  #9  
Παλιά 02-05-12, 14:43
Όνομα: Αλέξανδρος
Έκδοση λογισμικού Office: Ms-Office 2003, Ms-Office 2007, Ms-Office 2013
Γλώσσα λογισμικού Office: Ελληνική
 
Εγγραφή: 22-01-2010
Περιοχή: ΑΡΤΑ
Μηνύματα: 521
Προεπιλογή

Καλησπέρα Τάσο

'Οντως ό τρόπος που επέλεξα είναι πολύπλοκος.Δυσκολεύτηκα πολύ στο θέμα μαζικής αποστολής διότι απο ένα πίνακα ο οποίος περιέχει 2 πεδία contactName και telefonNumber έπρεπε να τα μεταφέρω με checkbox όλα τα νούμερα σε ένα πεδίο(txtTo) με πρόθεμα +30 και την σύνδεση αυτών με κόμμα(,).Ανάλογα την εταιρεία τι ζητάει(μερικές εταιρίες θέλουν ερωτηματικο(;) αντί το κόμμα(,)
Aπο εκεί μετά να κάνω την αποστολή.
Βεβαίως γνωρίζω ότι με την απάντηση του Server σε μήνυμα πχ Μid 000EB3 (μού το είχες εξηγήσει σε προηγούμενο μήνυμα)ότι το μήνυμα παραλήφθηκε από το server αλλά όχι από τον παραλήπτη.Επειδή εγώ αγόρασα κάποια μηνύματα και ΄΄εστειλα δοκιμαστικά στο κινητό μου όταν έβγαινε το Μid έφτανε και το μήνυμα.
Το API που δίνει η εταιρεία σε url για κάθε ενέργεια είναι διαφορετικό ΠΧ άλλο url για credits,για deletContact,για saveContacts,για multiplequery,για deleteMessage κλπ
Κάθε φορά θα πρέπει να γίνεται επερώτηση στο server και ο server θα απαντά ανάλογα σε μήνυμα.
Το ερώτημα μου ήταν στο θέμα μηνύματος όπως και μου απάντησες το MsgBox να το αντικαταστήσω.
Τώρα στο θέμα αποστολής πολλών μηνυμάτων.Το δοκίμασα με δέκα παραλήπτες και τα έστειλα κανονικά.
Ο κώδικας που χρησιμοποίησα για το check και την μεταφορά των επιλεγμένων τηλεφώνων σε ένα πεδίο( txtTo) είναι΄:

[CODEPrivate Sub chkSelectPhonebookItems_Click()
Dim i As Integer
With PhonebookList
For i = 0 To .ListCount - 1
.Selected(i) = chkSelectPhonebookItems.Value
Next i
End With
Call PhonebookList_Click

'txtFrom.Value = ""
'txtMessage.Value = ""

End Sub
__________________________________________________ ____
Private Sub PhonebookList_KeyUp(KeyCode As Integer, Shift As Integer)
Call PhonebookList_Click
End Sub
__________________________________________________ __
' Βάλτε τα επιλεγμένα στοιχεία του τηλεφωνικού καταλόγου στο πεδίο αριθμό τηλεφώνου (Put the selected phonebook items into phone number field)

Private Sub PhonebookList_Click()
Dim curPhone As String, curName As String, strPhones As String, strNames As String
Dim rowNum As Variant

' Πάρτε επιλεγμένους αριθμούς τηλεφώνου και ονόματα (Get selected phone numbers & names)
With PhonebookList
For Each rowNum In .ItemsSelected
curPhone = .Column(1, rowNum)
curName = .Column(0, rowNum)
strPhones = strPhones & ", " & curPhone
strNames = strNames & ", " & curName
Next rowNum
End With
If Len(strPhones) Then strPhones = mid$(strPhones, 3)
If Len(strNames) Then strNames = "(" & mid$(strNames, 3) & ")"

' Βάλτε τους στο πεδίο PhoneNumber (Put them on PhoneNumber field)
txtTo = Str2Null(strPhones)
txtContactName = strNames
End Sub
__________________________________________________ ______

Private Sub txtTo_Change()
txtContactName = ""
End Sub][/CODE]
__________________________________________________ _______
Η ανοχή του Server είναι μέχρι 100 τηλέφωνα κινητά με κάθε αποστολή .

Τώρα έχω πόσες εναλλαγές στο θέμα αποστολής SMS me Αctive x με internet explorer με reference XML κλπ

Ευχαριστώ πάντως για την πολύτιμη βοήθεια σου σ΄΄αυτήν την δύσκολη προσπάθεια αποπεράτωσης της εφαρμογής μου.

Φιλικά

Αλέξανδρος
Απάντηση με παράθεση
Απάντηση στο θέμα


Δικαιώματα - Επιλογές
Δε μπορείτε να δημοσιεύσετε νέα μηνύματα
Δε μπορείτε να δημοσιεύσετε απαντήσεις
Δεν μπορείτε να επισυνάψετε αρχεία
Δεν μπορείτε να επεξεργαστείτε τα μηνύματα σας

Ο κώδικας ΒΒ είναι σε λειτουργία
Τα Smilies είναι σε λειτουργία
Ο κώδικας [IMG] είναι σε λειτουργία
Ο κώδικας HTML είναι εκτός λειτουργίας
Trackbacks are εκτός λειτουργίας
Pingbacks are εκτός λειτουργίας
Refbacks are εκτός λειτουργίας


Παρόμοια Θέματα

Θέμα Δημιουργός Forum Απαντήσεις Τελευταίο Μήνυμα
[VBA] Ομαδική εισαγωγή στοιχείων steliosgr Excel - Ερωτήσεις / Απαντήσεις 7 22-07-16 23:20
[ Φόρμες ] Αποστολή Email mgeorge Access - Ερωτήσεις / Απαντήσεις 8 30-03-16 18:33
[ Φόρμες ] Αποστολή fax από Access marpapa Access - Ερωτήσεις / Απαντήσεις 8 26-05-13 22:00
[ Active X Controls ] Αποστολή SMS από Access synti Access - Ερωτήσεις / Απαντήσεις 2 19-03-13 14:41
Αποστολη sms Panos Mixos Access - Ερωτήσεις / Απαντήσεις 3 04-01-13 18:18


Η ώρα είναι 06:06.