Olá !
Você inclui este código no form on você colocou o componente crviewer1.
'' .....................................................................................
''isto eu carrego onde eu monto o relatório, no caso de passar fórmula via código
Type DB_RelFormula
campo As String
conteudo As String
End Type
Public St_RelFormula() As DB_RelFormula
Type db_RelN
WindowTitle As String
Connect As String
ReportFileName As String
SelectionFormula As String
SQLQuery As String
End Type
Public st_REL_N As db_RelN
Type db_RelSubN
SubreportToChange As String
SelectionFormula As String
SQLQuery As String
End Type
Public St_RelSubN() As db_RelSubN
''.........................................................................................
Dim crxApplication As New CRAXDRT.Application
Dim Report As CRAXDRT.Report
Dim SubReport() As CRAXDRT.Report
Private Sub Form_Load()
Dim crxDataBaseTable As CRAXDRT.DatabaseTable
ReDim SubReport(0 To UBound(St_RelSubN)) As CRAXDRT.Report
Set Report = crxApplication.OpenReport(App.Path & "Rel.rpt", 1)
For Each crxDataBaseTable In Report.DataBase.Tables
Para base mdb
crxDataBaseTable.Location = st_REL_N.Connect 'App.Path & "" & vgDataBaseName
ou para sql com dsn
crxDatabaseTable.SetLogOnInfo dsn, basedados, usuário, senha
Next crxDataBaseTable
fuEscondeToolTip
If st_REL_N.SelectionFormula <> "" Then '' no mesmo formato que é passado no designer do crystal
Report.RecordSelectionFormula = st_REL_N.SelectionFormula
endif
If st_REL_N.SQLQuery <> "" Then '' no mesmo formato que é passado no designer do crystal, caso voce passar uma query com outro filtro.
Report.SQLQueryString = st_REL_N.SQLQuery
endif
fuPassValorSubReport Report, SubReport(), cgRDC
fuPassValorFormula Report, cgRDC, 0
CRViewer1.Top = 0
CRViewer1.Left = 0
CRViewer1.Height = Me.ScaleHeight
CRViewer1.Width = Me.ScaleWidth
Relatorio.Caption = st_REL_N.WindowTitle
CRViewer1.EnableGroupTree = False
CRViewer1.ReportSource = Report
CRViewer1.ViewReport
End Sub
Function fuPassValorSubReport(Controle1, Controle2, Tipo)
Dim Ka As Long, Ka1 As Long
For Ka = 1 To UBound(St_RelSubN)
If Tipo = cgOCX Then
Controle1.SubreportToChange = St_RelSubN(Ka).SubreportToChange
Controle1.SelectionFormula = St_RelSubN(Ka).SelectionFormula
fuPassValorFormula Controle1, Tipo, Ka
Controle1.SubreportToChange = ""
Else
Set Controle2(Ka) = Controle1.OpenSubreport(St_RelSubN(Ka).SubreportToChange)
Controle2(Ka).RecordSelectionFormula = St_RelSubN(Ka).SelectionFormula
If St_RelSubN(Ka).SQLQuery <> "" Then Controle2(Ka).SQLQueryString = St_RelSubN(Ka).SQLQuery
fuPassValorFormula Controle2(Ka), Tipo, Ka
End If
Next Ka
End Function
Function fuPassValorFormula(controle, Tipo, Relatorio)
Dim Ka As Long
For Ka = 1 To UBound(St_RelFormula, 2)
If St_RelFormula(Relatorio, Ka).campo <> "" Then
If Tipo = cgOCX Then
controle.Formulas(Ka) = St_RelFormula(Relatorio, Ka).campo & "=" & St_RelFormula(Relatorio, Ka).conteudo
Else
controle.FormulaFields.GetItemByName(St_RelFormula(Relatorio, Ka).campo).Text = St_RelFormula(Relatorio, Ka).conteudo
End If
Else
Exit For
End If
Next Ka
End Function
Function fuEscondeToolTip()
Dim vCampo As Object, vNome As String, vflag As Boolean
Dim Sec As CRAXDRT.Section
Dim crxobject As Object
Dim x1 As Integer, n(0 To 1) As Integer
Dim vSecao(1 To 7) As String
On Error GoTo err_load
vSecao(1) = "RH"
vSecao(2) = "PH"
vSecao(3) = "GH"
vSecao(4) = "D"
vSecao(5) = "GF"
vSecao(6) = "PF"
vSecao(7) = "RF"
n(0) = 1
n(1) = 0
Do Until n(0) < 1
'n(0) = n(0) + 1
n(1) = 65
Do Until n(1) < 64
If n(1) > 64 Then
vNome = LCase(Chr(n(1)))
Else
vNome = ""
End If
vflag = True
On Error GoTo err_load_1
Set Sec = Report.Sections(UCase(vSecao(n(0))) & vNome)
On Error GoTo err_load
If vflag = False Then
If n(1) = 65 Then
n(1) = 64
Else
n(1) = 0
n(0) = n(0) + 1
If n(0) > 7 Then n(0) = 0
End If
Else
For x1 = 1 To Sec.ReportObjects.Count
Set vCampo = Sec.ReportObjects.Item(x1)
vCampo.ConditionFormula(crToolTipTextConditionFormulaType) = "chr(9)"
Next x1
n(1) = n(1) + 1
End If
Loop
Loop
Exit Function
err_load_1:
If Err = 9 Then
vflag = False
Resume Next
End If
err_load:
MsgBox "erro ", vbOKOnly + vbInformation, "Atenção"
Exit Function
Resume
End Function
