Estoi trabajando en un proyecto para poder hacer unas etiquetas. La question es que haveces son necesarias hacer duplicados en una misma pagina, por lo que necesito duplicarlas, tengo un boton que funciona a traves de un check box, donde pones si quieres duplicados, y cuantos, el problema esque no consigo que me lo haga por lo que ahora mismo me da error de "No coinciden los tipos" he probado y no consigo encontrar el porque, tiene que ver algo con el campo de bultos.
Adjunto codigo:
Cita:
Saludos y gracias por adelantado. Private Sub Ok_Click()
On Error GoTo Err_Ok_Click
Dim num_bultos
Dim error
Dim bultos As Integer
Dim i
Dim z
Dim num_copias
Dim rs As New ADODB.Recordset
Set rs = New ADODB.Recordset
i = 1
z = 1
error = "no"
DoCmd.SetWarnings False
DoCmd.RunSQL ("Delete * from etiquetador")
txtempresa.SetFocus
txtempresa.Text = UCase(txtempresa.Text)
If txtempresa.Text = "" Then
aviso = MsgBox("Introduzca la empresa destinataria", vbCritical)
error = "si"
End If
txtdir.SetFocus
txtdir.Text = UCase(txtdir.Text)
If txtdir.Text = "" Then
aviso = MsgBox("Introduzca la dirección", vbCritical)
error = "si"
End If
txtcp.SetFocus
If txtcp.Text = "" Then
aviso = MsgBox("Introduzca el código postal", vbCritical)
error = "si"
End If
txtpob.SetFocus
txtpob.Text = UCase(txtpob.Text)
If txtpob.Text = "" Then
aviso = MsgBox("Introduzca la población", vbCritical)
error = "si"
End If
txtprov.SetFocus
txtprov.Text = UCase(txtprov.Text)
If txtprov.Text = "" Then
aviso = MsgBox("Introduzca la provincia", vbCritical)
error = "si"
End If
txtref.SetFocus
txtref.Text = UCase(txtref.Text)
If txtref.Text = "" Then
aviso = MsgBox("Introduzca la referencia del producto", vbCritical)
error = "si"
End If
txtbultos.SetFocus
If txtbultos.Text = "" Then
aviso = MsgBox("Introduzca nº de bultos", vbCritical)
error = "si"
End If
If error = "no" Then
rs.Open "etiquetador", CurrentProject.Connection, adOpenDynamic, adLockBatchOptimistic
txtbultos.SetFocus
While i <= bultos
bultos = i & "/" & bultos
rs.AddNew
txtempresa.SetFocus
rs!empresa = txtempresa.Text
txtdir.SetFocus
rs!direccion = txtdir.Text
txtcp.SetFocus
rs!cp = txtcp.Text
txtpob.SetFocus
rs!poblacion = txtpob.Text
txtprov.SetFocus
rs!provincia = txtprov.Text
txtref.SetFocus
rs!referencia = txtref.Text
txtbultos.SetFocus
rs!bultos = bultos
rs.UpdateBatch
i = i + 1
Wend
rs.Close
''''Si se quiere imprimir
If timp.Value = True Then
DoCmd.OpenReport "Informe", acViewNormal
End If
If tcop.Value = True Then
rs.Open "etiquetador", CurrentProject.Connection, adOpenDynamic, adLockBatchOptimistic
txtbultos.SetFocus
If IsNumeric(txtbultos.Text) Then
bultos = CInt(txtbultos.Text)
Dim intCopia As Integer
txtcopia.SetFocus
intCopia = txtcopia.Text
While z <= intCopia
While i <= bultos
bultos = i & "/" & bultos
rs.AddNew
txtempresa.SetFocus
rs!empresa = txtempresa.Text
txtdir.SetFocus
rs!direccion = txtdir.Text
txtcp.SetFocus
rs!cp = txtcp.Text
txtpob.SetFocus
rs!poblacion = txtpob.Text
txtprov.SetFocus
rs!provincia = txtprov.Text
txtref.SetFocus
rs!referencia = txtref.Text
txtbultos.SetFocus
rs!bultos = bultos
rs.UpdateBatch
i = i + 1
Wend
z = z + 1
Wend
Else
aviso = MsgBox("Error de datos en los Bultos", vbCritical)
End If
rs.Close
End If
''''''''''''''''''''''''
MsgBox ("Etiquetas actualizadas")
DoCmd.Close
End If
Exit_Ok_Click:
Exit Sub
Err_Ok_Click:
MsgBox Err.Description
Resume Exit_Ok_Click
End Sub
On Error GoTo Err_Ok_Click
Dim num_bultos
Dim error
Dim bultos As Integer
Dim i
Dim z
Dim num_copias
Dim rs As New ADODB.Recordset
Set rs = New ADODB.Recordset
i = 1
z = 1
error = "no"
DoCmd.SetWarnings False
DoCmd.RunSQL ("Delete * from etiquetador")
txtempresa.SetFocus
txtempresa.Text = UCase(txtempresa.Text)
If txtempresa.Text = "" Then
aviso = MsgBox("Introduzca la empresa destinataria", vbCritical)
error = "si"
End If
txtdir.SetFocus
txtdir.Text = UCase(txtdir.Text)
If txtdir.Text = "" Then
aviso = MsgBox("Introduzca la dirección", vbCritical)
error = "si"
End If
txtcp.SetFocus
If txtcp.Text = "" Then
aviso = MsgBox("Introduzca el código postal", vbCritical)
error = "si"
End If
txtpob.SetFocus
txtpob.Text = UCase(txtpob.Text)
If txtpob.Text = "" Then
aviso = MsgBox("Introduzca la población", vbCritical)
error = "si"
End If
txtprov.SetFocus
txtprov.Text = UCase(txtprov.Text)
If txtprov.Text = "" Then
aviso = MsgBox("Introduzca la provincia", vbCritical)
error = "si"
End If
txtref.SetFocus
txtref.Text = UCase(txtref.Text)
If txtref.Text = "" Then
aviso = MsgBox("Introduzca la referencia del producto", vbCritical)
error = "si"
End If
txtbultos.SetFocus
If txtbultos.Text = "" Then
aviso = MsgBox("Introduzca nº de bultos", vbCritical)
error = "si"
End If
If error = "no" Then
rs.Open "etiquetador", CurrentProject.Connection, adOpenDynamic, adLockBatchOptimistic
txtbultos.SetFocus
While i <= bultos
bultos = i & "/" & bultos
rs.AddNew
txtempresa.SetFocus
rs!empresa = txtempresa.Text
txtdir.SetFocus
rs!direccion = txtdir.Text
txtcp.SetFocus
rs!cp = txtcp.Text
txtpob.SetFocus
rs!poblacion = txtpob.Text
txtprov.SetFocus
rs!provincia = txtprov.Text
txtref.SetFocus
rs!referencia = txtref.Text
txtbultos.SetFocus
rs!bultos = bultos
rs.UpdateBatch
i = i + 1
Wend
rs.Close
''''Si se quiere imprimir
If timp.Value = True Then
DoCmd.OpenReport "Informe", acViewNormal
End If
If tcop.Value = True Then
rs.Open "etiquetador", CurrentProject.Connection, adOpenDynamic, adLockBatchOptimistic
txtbultos.SetFocus
If IsNumeric(txtbultos.Text) Then
bultos = CInt(txtbultos.Text)
Dim intCopia As Integer
txtcopia.SetFocus
intCopia = txtcopia.Text
While z <= intCopia
While i <= bultos
bultos = i & "/" & bultos
rs.AddNew
txtempresa.SetFocus
rs!empresa = txtempresa.Text
txtdir.SetFocus
rs!direccion = txtdir.Text
txtcp.SetFocus
rs!cp = txtcp.Text
txtpob.SetFocus
rs!poblacion = txtpob.Text
txtprov.SetFocus
rs!provincia = txtprov.Text
txtref.SetFocus
rs!referencia = txtref.Text
txtbultos.SetFocus
rs!bultos = bultos
rs.UpdateBatch
i = i + 1
Wend
z = z + 1
Wend
Else
aviso = MsgBox("Error de datos en los Bultos", vbCritical)
End If
rs.Close
End If
''''''''''''''''''''''''
MsgBox ("Etiquetas actualizadas")
DoCmd.Close
End If
Exit_Ok_Click:
Exit Sub
Err_Ok_Click:
MsgBox Err.Description
Resume Exit_Ok_Click
End Sub