تغير أسماء الأعمدة في التقرير

[1DAOUD]

السلام عليكم أحتاج إلى تغيير عناوين الأعمد في التقرير بشكل تلقائي حسب العناوين الموجودة في الإستعلام الجدولي أي تتزايد حسب المعطيات في الجدول

[kanory]

2 ساعات مضت, 1DAOUD said:

السلام عليكم أحتاج إلى تغيير عناوين الأعمد في التقرير بشكل تلقائي حسب العناوين الموجودة في الإستعلام الجدولي أي تتزايد حسب المعطيات في الجدول

ممكن مثال لماتريد للتطبيق عليه

[Eng.Qassim]

وعليكم السلام

انسخ هذا السبروتين لديك  ..عند تشغيل التقرير كل مرة يأخذ قيمه من الاستعلام الجدولي

قم بتسمية حقول التقرير بأسماء مثل Field1,Field2  الخ ...لان اسم الحقل في الكود هو Field واجعلها مثلا سبعة حقول

Dim ReportLabel(7) As String
Sub CreateReportQuery()
On Error GoTo Err_CreateQuery
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field
Dim indexx As Integer
Dim FieldList As String
Dim strSQL As String
Dim i As Integer

Set db = CurrentDb
Set qdf = db.QueryDefs("qryReductionByPhysician_Crosstab")
indexx = 0
    For Each fld In qdf.Fields
        If fld.Type >= 1 And fld.Type <= 8 Or fld.Type = 10 Then
            FieldList = FieldList & "[" & fld.Name & "] as Field" & indexx & ", "
            ReportLabel(indexx) = fld.Name
        End If
'           MsgBox Label(indexx)
        indexx = indexx + 1
    Next fld
    For i = indexx To 7
            FieldList = FieldList & "null as Field" & i & ","
     Next i
     FieldList = Left(FieldList, Len(FieldList) - 1)
     
 strSQL = "Select " & FieldList & " From qryReductionByPhysician_Crosstab"
 
    db.QueryDefs.Delete "qryCrossTabReport"
    Set qdf = db.CreateQueryDef("qryCrossTabReport", strSQL)
 
 
 
Exit_CreateQuery:
    Exit Sub
    
Err_CreateQuery:
    If Err.Number = 3265 Then   '*** if the error is the query is missing
        Resume Next             '*** then skip the delete line and resume on the next line
    Else
        MsgBox Err.Description      '*** write out the error and exit the sub
        Resume Exit_CreateQuery
    End If
End Sub

ثم قم بأستدعائه من حدث عند فتح التقرير وضع الكود التالي

 

Dim i As Integer
    For i = 0 To 7
        ReportLabel(i) = ""
    Next i
    Call CreateReportQuery

 

في راس التقرير قم بوضع مربعات نص ..مثلا سبعة كعدد الحقول واجعل مصدر السجلات

=filllabel(0) ,=filllabel(1) وهكذا

 

ثم انسخ الكود التالي

Function FillLabel(LabelNumber As Integer) As String
FillLabel = Nz(ReportLabel(LabelNumber), "")

End Function

بالتوفيق ان شاء الله

تم تعديل أغسطس 14, 2021 بواسطه Eng.Qassim

[1DAOUD]

15 - Copie.accdb

[Eng.Qassim]

1 hour ago, 1DAOUD said:

15 - Copie.accdb 648 kB · 3 downloads

تفضل واخبرنا بالنتائج

15 - CopieQ.accdb

[1DAOUD]

عند إضافة أي فرع تظهر رسالة ويتم حذف الاستعلام

 

[د.كاف يار]

تفضل هذه مشاركتي

اضف ازارا اننشاء تقرير و ضع الشفرة التالية حدث عند النقر

Dim ctlLabel As Control, ctlText As Control
Dim intDataX As Integer, intDataY As Integer
Dim intLabelX As Integer, intLabelY As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
 intLabelX = 100
 intLabelY = 100
 intDataX = 1000
 intDataY = 100
 Set rpt = Application.CreateReport
 rpt.RecordSource = "TRANSFORM Sum(الخزينة.المداخيل) AS Sumمنالمداخيل SELECT الخزينة.البيان, الخزينة.التصنيف, Sum(الخزينة.المداخيل) AS [إجمالي المداخيل] FROM الخزينة GROUP BY الخزينة.البيان, الخزينة.التصنيف PIVOT الخزينة.[الفرع/المصلحة];"

 Set rs = CurrentDb.OpenRecordset("TRANSFORM Sum(الخزينة.المداخيل) AS Sumمنالمداخيل SELECT الخزينة.البيان, الخزينة.التصنيف, Sum(الخزينة.المداخيل) AS [إجمالي المداخيل] FROM الخزينة GROUP BY الخزينة.البيان, الخزينة.التصنيف PIVOT الخزينة.[الفرع/المصلحة];")
    Dim x, x2 As Integer
    
        For x = 0 To rs.Fields.Count - 1
            Set ctlText = CreateReportControl(rpt.Name, acLabel, acPageHeader, , rs.Fields(x).Name, _
            intDataX * x, 0, 555)
            ctlText.Name = rs.Fields(x).Name & x
            Set ctlText = CreateReportControl(rpt.Name, acTextBox, acDetail, , rs.Fields(x).Name, _
            intDataX * x, 0, 555)
            ctlText.Name = rs.Fields(x).Name
        Next
       
    rs.Close
    Set rs = Nothing
    rpt.RecordSource = "الخزينة_Crosstab"

 

[Eng.Qassim]

40 minutes ago, 1DAOUD said:

عند إضافة أي فرع تظهر رسالة ويتم حذف الاستعلام

 

 

 

هذه بسيطة انا جعلتها على مدى الحقول التي لديك ... قم بزيادة الحقول في الاستعلام qryCrossTabReport قد ماتشاء

ونفس العدد اضفه للتقرير واجعل جميع الحقول والعناوين can shrink=yes حتى لاتظهر لديك الفروع الغير موجود لكن عند اضافتها ستظهر لك

ولا تنسى تغيير الدوران في الكود حسب عدد الحقول لديك مثلا Dim ReportLabel(10) As String  و For i = 0 To 10

For i = indexx To 10

حاول ان تجرب عدد من الحقول وتغير في الكود ستنجح لديك

[Eng.Qassim]

15 minutes ago, د.كاف يار said:

تفضل هذه مشاركتي

اضف ازارا اننشاء تقرير و ضع الشفرة التالية حدث عند النقر

Dim ctlLabel As Control, ctlText As Control
Dim intDataX As Integer, intDataY As Integer
Dim intLabelX As Integer, intLabelY As Integer
Dim db As DAO.Database
Dim rs As DAO.Recordset
 intLabelX = 100
 intLabelY = 100
 intDataX = 1000
 intDataY = 100
 Set rpt = Application.CreateReport
 rpt.RecordSource = "TRANSFORM Sum(الخزينة.المداخيل) AS Sumمنالمداخيل SELECT الخزينة.البيان, الخزينة.التصنيف, Sum(الخزينة.المداخيل) AS [إجمالي المداخيل] FROM الخزينة GROUP BY الخزينة.البيان, الخزينة.التصنيف PIVOT الخزينة.[الفرع/المصلحة];"

 Set rs = CurrentDb.OpenRecordset("TRANSFORM Sum(الخزينة.المداخيل) AS Sumمنالمداخيل SELECT الخزينة.البيان, الخزينة.التصنيف, Sum(الخزينة.المداخيل) AS [إجمالي المداخيل] FROM الخزينة GROUP BY الخزينة.البيان, الخزينة.التصنيف PIVOT الخزينة.[الفرع/المصلحة];")
    Dim x, x2 As Integer
    
        For x = 0 To rs.Fields.Count - 1
            Set ctlText = CreateReportControl(rpt.Name, acLabel, acPageHeader, , rs.Fields(x).Name, _
            intDataX * x, 0, 555)
            ctlText.Name = rs.Fields(x).Name & x
            Set ctlText = CreateReportControl(rpt.Name, acTextBox, acDetail, , rs.Fields(x).Name, _
            intDataX * x, 0, 555)
            ctlText.Name = rs.Fields(x).Name
        Next
       
    rs.Close
    Set rs = Nothing
    rpt.RecordSource = "الخزينة_Crosstab"

 

عمل رائع استاذنا @د.كاف يارلكنه بحاجة الى تنسيق الحقول من داخل الكود

[د.كاف يار]

19 دقائق مضت, Eng.Qassim said:

عمل رائع استاذنا @د.كاف يارلكنه بحاجة الى تنسيق الحقول من داخل الكود

نعم صحيح يا بش مهندس يحتاج لتنسيق لكنها مجرد فكرة لأن السائل لم يوضح طلبه بالتفصيل و الموضوع انشاء الله سهل

من خلال الحلقة التكرارية يستطيع تنسيق مايشاء