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 |