MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access


    Ajuste Codigo

    avatar
    ssvp
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 100
    Registrado : 15/01/2013

    Ajuste Codigo Empty Ajuste Codigo

    Mensagem  ssvp 9/6/2016, 14:22

    Este é um sistema de sorteio de bingo e verifiquei que nao esta correto a geracao de cartelas. Seria possível alguem verificar este codigo e verificar o seguinte: as pedras de 1 a 20 devem sair para a coluna B, de 21 a 40 para coluna I, de 41 a 60 para acoluna N, de 61 a 80 para coluna G e de 81 a 100 na coluna O.

    Como nao conheco de programacao , penso que o problema pode estar no codigo a seguir, porem nao consigo corrigí-lo.

    José Silvio
    avatar
    ssvp
    Intermediário
    Intermediário


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 100
    Registrado : 15/01/2013

    Ajuste Codigo Empty Esqueci de colar o codigo, desculpem

    Mensagem  ssvp 9/6/2016, 14:45

    Sub FillCardsSTD(lngCardCount As Long, Optional blnFreeSpace As Boolean = False)

    On Error GoTo Err_FillCards_Click

    Dim myDB As Database
    Dim rsCards As Recordset
    Dim intCellCounter As Integer
    Dim lngCardCounter As Long
    Dim fldCurrentField As Field

    Set myDB = CurrentDb()
    Set rsCards = myDB.OpenRecordset("tblCards", dbOpenDynaset)
    '---Main

    'clear cards table
    DoCmd.SetWarnings False
    DoCmd.OpenQuery "qrdClearCards"
    DoCmd.SetWarnings True

    'Set up outer loop to iterate the once for each card specified in txtNumCards
    For lngCardCounter = 1 To lngCardCount
    rsCards.AddNew
    rsCards!cardno = lngCardCounter
    'setup inner loop to iterate across the current record and fill with selected values
    Set fldCurrentField = rsCards.Fields(0) 'cell 0 = cardno and is the card sequence number
    fldCurrentField.Value = lngCardCounter
    For intCellCounter = 1 To 25 'the rest of the cells
    Set fldCurrentField = rsCards.Fields(intCellCounter)
    Select Case intCellCounter
    Case 1, 6, 11, 16, 21 'the B column
    fldCurrentField.Value = FindRandom_TSB("", "tblB", "CellContents")
    Case 2, 7, 12, 17, 22 'the I column
    fldCurrentField.Value = FindRandom_TSB("", "tblI", "CellContents")
    Case 3, 8, 13, 18, 23 'the N column
    If Not intCellCounter = 13 Then
    fldCurrentField.Value = FindRandom_TSB("", "tblN", "CellContents")
    ElseIf blnFreeSpace Then
    fldCurrentField.Value = "AtivoAccess"
    Else
    fldCurrentField.Value = FindRandom_TSB("", "tblN", "CellContents")
    End If
    Case 4, 9, 14, 19, 24 'the G column
    fldCurrentField.Value = FindRandom_TSB("", "tblG", "CellContents")
    Case 5, 10, 15, 20, 25 'the O column
    fldCurrentField.Value = FindRandom_TSB("", "tblO", "CellContents")
    Case Else
    End Select
    Next 'Card field
    'save/commit new record before moving to next row
    rsCards.Update
    'clear used flags in Cell Contents table
    DoCmd.SetWarnings False
    DoCmd.OpenQuery "qruSetUsedtoFalseB"
    DoCmd.OpenQuery "qruSetUsedtoFalseI"
    DoCmd.OpenQuery "qruSetUsedtoFalseN"
    DoCmd.OpenQuery "qruSetUsedtoFalseG"
    DoCmd.OpenQuery "qruSetUsedtoFalseO"
    DoCmd.SetWarnings True
    Next 'Card record
    '---Clean up
    Set rsCards = Nothing
    Set myDB = Nothing

    Exit_FillCards_Click:
    Exit Sub

    Err_FillCards_Click:
    MsgBox Err.Description
    Resume Exit_FillCards_Click

    End Sub

      Data/hora atual: 8/11/2024, 04:01