Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Preguntas/Respuestas » Preguntas por Contestar » Visual Basic » Contestar

RESPONDER UNA PREGUNTA

Volver
Agregar una pregunta
Buscar
Si para responder la pregunta, crees necesario enviar un archivo adjunto, puedes hacerlo a traves del correo [email protected]

    Pregunta:  67151 - CRYSTAL REPORTS COLGADO
Autor:  Claudia Lima
Tengo el siguiente codigo VB que genera un reporte en Crystal reports pero se me queda colgado cuando lo ejecuto

Option Explicit
Dim Aplicacion As CRAXDRT.Application
Dim Reporte As CRAXDRT.report
Dim parametros As CRAXDRT.ParameterFieldDefinitions
Dim CamposOrden As CRAXDRT.SortFields

Dim ObjUtil As CafUtil.DBUtil2
Dim bd As ClassParam
Dim rsSeeks As ADODB.Recordset

Dim Pagina As Boolean
Dim mvarSelecctionFormula As String
Dim mvarFiltro As String
Dim Valida As Boolean
Dim pBoolLoad As Boolean

'Crea los recordset para los reportes
Dim rsDetCia As ADODB.Recordset
Dim rsMovs As ADODB.Recordset
Dim rsActivo As ADODB.Recordset
Dim rsEmps As ADODB.Recordset
Dim rsTiposMov As ADODB.Recordset

Private Sub Form_Load()

Set ObjUtil = New CafUtil.DBUtil2
Set rsSeeks = New ADODB.Recordset
Set Aplicacion = CreateObject("CrystalRuntime.Application.10")
'Pagina = False
pBoolLoad = True

End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Aplicacion = Nothing
Set Reporte = Nothing
Set parametros = Nothing
Set CamposOrden = Nothing

Set ObjUtil = Nothing
Set bd = Nothing
Set rsSeeks = Nothing

Set rsDetCia = Nothing

End Sub

Private Sub Impresiones1_ClickConfig()
On Error GoTo Cancela
menuprin.Dialog1.Flags = cdlPDPrintSetup
menuprin.Dialog1.ShowPrinter
ParamSis.NombrePrint = Printer.DeviceName
ParamSis.PuertoPrint = Printer.Port
ParamSis.DriverPrint = Printer.DriverName
Exit Sub
Cancela:
Screen.MousePointer = 0
Exit Sub
End Sub
Private Sub Impresiones1_ClickDisco()
'Reporte.PaperOrientation = crLandscape
With Impresiones1
'RepDisco.reporta tmpDesCor & " " & Format(Date, "yymmdd")
'RepDisco.reporta "Resguardo " & Format(Date, "yymmdd")
RepDisco.reporta2 Reporte, repListado & " " & Format(Date, "yymmdd")
End With
End Sub

Private Sub Impresiones1_ClickImpresora()
On Error GoTo ErrHandler
Screen.MousePointer = vbHourglass
Call Reporte.SelectPrinter(ParamSis.DriverPrint, ParamSis.NombrePrint, ParamSis.PuertoPrint)
If Pagina Then
Reporte.PaperOrientation = crLandscape
Else
Reporte.PaperOrientation = crPortrait
End If
If Valida Then Reporte.PrintOut False
Screen.MousePointer = 0
Exit Sub
ErrHandler:
Screen.MousePointer = 0
MsgBox Err.Description & vbLf & Err.Source, vbCritical, App.ProductName & " error No. " & Err.Number
End Sub
Private Sub Impresiones1_ClickPantalla()
Call Reporte.SelectPrinter(ParamSis.DriverPrint, ParamSis.NombrePrint, ParamSis.PuertoPrint)
If Pagina Then
Reporte.PaperOrientation = crLandscape
Else
'Reporte.PaperOrientation = crPortrait
Reporte.PaperOrientation = crLandscape

End If
Screen.MousePointer = vbHourglass
Me.Enabled = False
'menuprin.Enabled = False
If Valida Then previo2.Previo Reporte
'menuprin.Enabled = True
'Me.Show vbModal, menuprin
Me.Enabled = True
Screen.MousePointer = 0
End Sub
Private Sub Impresiones1_ClickSalir()
Unload Me
End Sub
Private Sub Impresiones1_ClickTodo(Cancel As Boolean)
On Error GoTo ErrHandler
Dim i As Integer
Dim DBTable As CRAXDRT.DatabaseTable
Dim CPProperty As CRAXDRT.ConnectionProperty
Dim parametro As CRAXDRT.ParameterFieldDefinition
'Dim CRXDBField As CRAXDRT.FieldObject

Set rsDetCia = New ADODB.Recordset
Set rsDetCia = ObjUtil.GetDbReadOnly(ParamCia.CnstrDB, "DETCIA")
Screen.MousePointer = vbHourglass
Set Reporte = Nothing
'--------------------------------------------------------------------------------------------

Set Reporte = Aplicacion.OpenReport(RepDir & "bitacora2.rpt")

Set rsMovs = New ADODB.Recordset
Set rsActivo = New ADODB.Recordset
Set rsEmps = New ADODB.Recordset
Set rsTiposMov = New ADODB.Recordset


Set rsMovs = ObjUtil.GetDbReadOnly(ParamCia.CnstrDB, "MOVIMIENTOS")
Set rsActivo = ObjUtil.GetDbReadOnly(ParamCia.CnstrDB, "ACTIVOS")
Set rsEmps = ObjUtil.GetDbReadOnly(ParamCia.CnstrDB, "EMPLEADOS")
Set rsTiposMov = ObjUtil.GetDbReadOnly(ParamCia.CnstrDB, "TIPOSMOV")
'++++
Carga_Recordset
Reporte.DiscardSavedData
Set parametros = Reporte.ParameterFields
Valida = True
' If Obtiene_Formula Then
' Reporte.RecordSelectionFormula = mvarSelecctionFormula
' Else
' Reporte.RecordSelectionFormula = ""
' End If
If Not Valida Then
Screen.MousePointer = 0
Exit Sub
End If

'Carga_Recordset
For i = 1 To parametros.Count
Select Case parametros.Item(i).Name
Case "{?NOMCIA}"
Set parametro = parametros.Item(i)
parametro.SetCurrentValue CStr(Empresa.NombreCia)
Case "{?prm_Filtro}"
Set parametro = parametros.Item(i)
parametro.SetCurrentValue "Ordenados por numero consecutivo"

Case "{?RANGO}"
Set parametro = parametros.Item(i)
parametro.SetCurrentValue "Ordenados por numero consecutivo"

Case "{?TisaUsr}"
Set parametro = parametros.Item(i)
parametro.SetCurrentValue CStr(Empresa.NombreUsuario)
Case "{?DIR1}"
Set parametro = parametros.Item(i)
parametro.SetCurrentValue "DIRECCION GENERAL DE RECURSOS MATERIALES Y SERVICIOS GENERALES /n DIRECCION DE RECURSOS MATERIALES /n SUBDIRECCION DE ALMACEN E INVENTARIOS"


End Select
Next
'Set parametro = Nothing


Screen.MousePointer = vbDefault
Exit Sub
'--------------------------------------------------------------------------------------------------------
ErrHandler:
Screen.MousePointer = 0
MsgBox Err.Description & Chr(13) & Err.Source, vbCritical, "Erro No " & Err.Number
End Sub
Private Sub Carga_Recordset()
Dim iFil As Integer
For iFil = 1 To Reporte.DataBase.Tables.Count
Select Case UCase(Reporte.DataBase.Tables.Item(iFil).Name)
Case "DETCIA"
Reporte.DataBase.Tables.Item(iFil).SetPrivateData 3, rsDetCia
Case "ACTIVOS"
Reporte.DataBase.Tables.Item(iFil).SetPrivateData 3, rsActivo
Case "MOVIMIENTOS"
Reporte.DataBase.Tables.Item(iFil).SetPrivateData 3, rsMovs
Case "EMPLEADOS"
Reporte.DataBase.Tables.Item(iFil).SetPrivateData 3, rsEmps
Case "TIPOSMOV"
Reporte.DataBase.Tables.Item(iFil).SetPrivateData 3, rsTiposMov
End Select
Next iFil
End Sub

Private Function Obtiene_Formula() As Boolean
Dim cons As Integer

Valida = True
mvarFiltro = ""
mvarSelecctionFormula = ""
mvarFiltro = "BITACORA DE MOVIMIENTOS"
If Len(Trim(txtCons.Text)) > 0 Then
cons = txtCons.Text
mvarFiltro = mvarFiltro & " del Movimiento " & txtCons.Text
mvarSelecctionFormula = "{MOVIMIENTOS.CVEACT}={ACTIVOS.CVEACT} and {MOVIMIENTO.CVEUSU}={EMPLEADOS.CVEUSU} and {EMPLEADOS.ESTATUS}='A' and {MOVIMIENTOS.TIPMOV}={TIPOSMOV.CVETIMOV} and {MOVIMIENTOS.NUMCONS}=" & cons
Else
mvarSelecctionFormula = "{MOVIMIENTOS.CVEACT}={ACTIVOS.CVEACT} and {MOVIMIENTO.CVEUSU}={EMPLEADOS.CVEUSU} and {EMPLEADOS.ESTATUS}='A' and {MOVIMIENTOS.TIPMOV}={TIPOSMOV.CVETIMOV}"
End If
Obtiene_Formula = True
End Function
Private Sub cmdBusCons_Click()
txtCons.Text = BusGrid.GetClaveTexto18("Bitacora de Movimientos" & lb_obs.Caption, ParamSis.CnstrDB, Trim(lb_obs.Caption))

txtCons.SetFocus
End Sub


Nombre
Apellidos
Correo
Comentarios