my code

Web Service para Access Pro, prepara cursos

Snippet options

Download: Download snippet as web-service-prepara-cursos.vbs.
Copy snippet: For this you need a free my code account.
Embed code : You will find the embed code for this snippet at the end of the page, if you want to embed it into a website or a blog!

Public Function PreparaCursos()
On Error GoTo ErrControl
Dim Webs As Object
Dim Cursos
Dim Response As Object
Dim ssql As String
Dim i As Long, k As Long
Dim arrFields() As String
Dim strFields As String, strValues As String
    DoCmd.Hourglass True
    PreparaCursos = False
    Debug.Print Time
    Set Webs = CreateObject("MSSOAP.SoapClient30")
    Webs.MSSoapInit ""
    Webs.ConnectorProperty("Timeout") = 300000
    Set Response = Webs.AutenticaUser("maestro", "maestrogilberto")
    chave = Response.Item(4).Text
    Cursos = Webs.getfollowup(chave)
    If UBound(Cursos) > 0 Then
        'Verifica se existe tabela
        Set Response = Cursos(0)
        ReDim arrFields(Response.length)
        For i = 0 To Response.length - 1
            arrFields(i) = Response.Item(i).baseName
        Next i
        If DCount("*", "MSysObjects", "Name='tblPreparaCursos'") = 0 Then
          'Constroi tabela
            ssql = vbNullString
            ssql = ssql & "Create Table tblPreparaCursos (" & Join(arrFields, " string(120),")
            ssql = Left$(ssql, Len(ssql) - 1) & ")"
            CurrentProject.Connection.Execute (ssql)
        End If
        For k = 0 To UBound(Cursos) - 1
            Set Response = Cursos(k)
            strFields = vbNullString
            strValues = vbNullString
            For Each r In Response
                strFields = strFields & "[" & r.baseName & "],"
                strValues = strValues & "'" & Replace(r.Text, "'", "´") & "',"
                'Debug.Print r.Text
            strFields = Left(strFields, Len(strFields) - 1)
            strValues = Left(strValues, Len(strValues) - 1)
            CurrentDb.Execute "Insert into tblPreparaCursos (" & strFields & ") values (" & strValues & ")"
        Next k
    End If
    PreparaCursos = True
    Set Webs = Nothing
    Set Cursos = Nothing
    Set Response = Nothing
    Erase arrFields
    Debug.Print Time
    DoCmd.Hourglass False
    Exit Function
    MsgBox "Erro: " & Err.Description, vbCritical, "AccessPro"
    Resume Finally
End Function

Create a free my code account now.

my code is a free service, which allows you to save and manage code snippes of any kind and programming language. We provide many advantages for your daily work with code-snippets, also for your teamwork. Give it a try!

Find out more and register now

You can customize the height of iFrame-Codes as needed! You can find more infos in our API Reference for iframe Embeds.