المساعدة فى تنسيق التاريخ داخل التكست بوكس الخاص بالفورم

[عادل ابوزيد]

السلام عليكم مرفقد ملف به فورم خاص بالبحث مع امكانية التعديل حيث يظهر النتائج داخل تكست بوكس والخاانات الخاصة بالاعمدة التى بها تاريخ تنسيقها يظهر سنة / يوم / شهر والمطلوب اظهارها بنفس تنسيق الخلية وهو يوم  / شهر / سنة 

تقبلوا تحياتى

تنسيق الفورم.rar

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

تم تعديل الاكواد لتتناسب مع طلبك مع  تغيير طريقة تعديل البيانات ليتم تنفيدها عند الظغط على زر التعديل 

Option Explicit
Private Const Mysh_Name As String = "البداية"
Private Const MyFind_Column As Integer = 5
Private Const iHeight As Integer = 20
Private Sub kh_Add_Controls(MyCont As Control, MyTop As Double, MyHeight As Double, iRo As Long, rowData() As String)
    Dim MyTxt As Control
    Dim i As Integer
    For i = 1 To UBound(rowData)
        Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, i + 2).Address, True)
        With MyTxt
            .Move MyCont.Controls(i - 1).Left, MyTop, MyCont.Controls(i - 1).Width, MyHeight
            .MultiLine = True
            .Text = rowData(i)
        End With
        With Worksheets(Mysh_Name).Cells(iRo, i + 2)
            MyTxt.TextAlign = Me.kh_TextAlign(.HorizontalAlignment)
            MyTxt.Font.Bold = .Font.Bold
            MyTxt.Font.Size = .Font.Size
            MyTxt.FontName = .Font.Name
        End With
    Next i
    Set MyTxt = Nothing
End Sub
Private Sub kh_Find(MyText As String)
' البحث
    Dim MyHght As Double, MyTp As Double
    Dim Last As Long, ii As Long
    Dim Found As Boolean
    Found = False

    With Me.Frame1
        MyTp = .Controls(0).Top + .Controls(0).Height + 2
    End With
    Application.ScreenUpdating = False
    With Worksheets(Mysh_Name)
        Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row
        For ii = 2 To Last
            If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then
                MyHght = .Rows(ii).RowHeight
                
                Dim rowData(1 To 12) As String  'الأعمدة من C إلى N
                Dim i As Integer
                For i = 3 To 14
                    If i = 4 Or i = 9 Or i = 11 Or i = 12 Or i = 13 Then ' D, I, K, L, M
                        If IsDate(.Cells(ii, i).Value) Then
                            rowData(i - 2) = Format(.Cells(ii, i).Value, "yyyy/mm/dd")
                        Else
                            rowData(i - 2) = CStr(.Cells(ii, i).Value)
                        End If
                    Else
                        rowData(i - 2) = CStr(.Cells(ii, i).Value)
                    End If
                Next i

                If MyHght < iHeight Then MyHght = iHeight
                kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, rowData
                MyTp = MyTp + MyHght + 2
                
                Found = True
            End If
        Next
    End With
    
    If Not Found Then
        MsgBox TextBox_Find.Value & " " & "رقم الملف غير موجود", vbExclamation
       Me.TextBox_Find.Value = ""
    End If

    If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp
    Application.ScreenUpdating = True
End Sub
Private Function FormatDate(dateValue As Variant) As String
    If IsDate(dateValue) Then
        FormatDate = Format(dateValue, "yyyy/mm/dd")
    Else
        FormatDate = ""
    End If
End Function
Private Sub Button_Save_Click()
' تعديل البيانات
If Me.TextBox_Find.Value = "" Then Exit Sub

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

    Dim MyCon As Control
    Dim cellAddress As String
    Dim cellValue As String
    On Error Resume Next
    For Each MyCon In Me.Frame1.Controls
        If TypeName(MyCon) = "TextBox" Then
            cellAddress = MyCon.Name
            cellValue = MyCon.Text
            Worksheets(Mysh_Name).Range(cellAddress).Value = cellValue
        End If
    Next MyCon
    On Error GoTo 0
    Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

    MsgBox "تم حفظ التعديلات بنجاح", vbInformation
End Sub
Private Sub kh_Remove()
    On Error Resume Next
    Dim MyCon As Control
    Me.Frame1.ScrollHeight = 0
    For Each MyCon In Me.Frame1.Controls
        If TypeName(MyCon) = "TextBox" Then
            Me.Frame1.Controls.Remove MyCon.Name
        End If
    Next MyCon
    On Error GoTo 0
End Sub
Private Sub Button_Find_Click()
If Me.TextBox_Find.Value = "" Then MsgBox "يرجى إظافة رقم الملف", vbInformation: Exit Sub

    kh_Remove
    If Len(Trim(Me.TextBox_Find.Text)) Then
        kh_Find Me.TextBox_Find
    End If
End Sub
Private Sub TextBox_Find_Change()
    kh_Remove
End Sub
Function kh_TextAlign(MyAlign) As Integer
    Dim Ag
    Dim A As Integer
    For A = 1 To 3
        Ag = Choose(A, -1131, -1108, -1152)
        If Ag = MyAlign Then kh_TextAlign = A: Exit Function
    Next
    kh_TextAlign = 1
End Function

 

تنسيق الفورم.rar

[عادل ابوزيد]

السلام عليكم ورحمه الله وبركاته

استاذى الفاضل محمد هشام .. اثلجتم صدرى فرحاً بعدما فقدت الامل فى التعديل .. ارتسمت ابتسامة عريضة على وجهى وكنت خلاص حقفل الجهاز 

اسعد الله قلبك وشرح صدرك وزادك من علمه وفضله 

اسمح لى بطلب ان شاء الله يكون بسيط .. وهو التحكم فى نتائح البحث بمعنى محازاه الكتابة تكون من اليمين لليسار   ... ثانياً : اظهار جميع البيانات الموجودة بالخلية التى تم استدعائها فمثلاً هناك بعض الخانات التاريخ ليس كامل ( مختفى ) وكذلك الخانات اسفل المسلسل ليست كاملة .. توحيد نوع الخط فى جميع البيانات 

بارك الله لك وفيك تقبل شكرى وتقديرى

[محمد هشام.]

أستاذ @عادل ابوزيد  في وجهة نظري المتواضعة  أنت فقط تعقد عليك الأمور يمكنك تعويض عناصر التيكست بوكس بقائمة ليست بوكس  مما يسهل عليك عملية البحث  والفلترة   بالمعيار الذي تختاره.  وإمكانية إظافة خصائص أخرى مستقبلا كالترحيل  والحذف ...    خاصة  أن عدد الصفوف على الملف كبير  .

  مع الاستفادة  من جميع  ما جاء في طلبك الاخير  

 

 

[عادل ابوزيد]

استاذى الفاضل محمد هشام 

اخوك بحث كتير وتلاحظت نفس المشكلة فى تنسيق التاريخ فاخترت من وجهى نظرى الابسط ... فلو امكن هناك حل افضل ... برجاء تدلنى عليه بملف من عندك 

جزاك الله كل خير تقبل منى تقديرى وشكرى

[محمد هشام.]

 

بسيطة  😉  سوف أحاول تعديل الأكواد السابقة  على هذا الملف  بطريقة مختلفة لتتمكن من عرض البيانات بالشكل المطلوب مع بعض التحسينات 

تفضل اخي @عادل ابوزيد

 

Option Explicit

Private Const Mysh_Name As String = "البداية"
Private Const MyFind_Column As Integer = 5
Private Const iHeight As Integer = 20
Private iGblInhibitTextBoxEvents As Boolean
Private Sub UserForm_Initialize()
    kh_Add_Labels Me.Frame2, 5
    Me.Frame2.BorderStyle = 0
End Sub
Private Sub kh_Add_Controls(MyCont As Control, MyTop As Double, MyHeight As Double, iRo As Long, rowData() As String)
    Dim MyTxt As Control
    Dim i As Integer
    Dim tmp As Double
    Dim Colarr(1 To 12) As Double
    Dim columnHeights(1 To 12) As Double
    Dim defaultWidths As Variant
    defaultWidths = Array(68, 80, 80, 130, 170, 110, 80, 90, 80, 80, 80, 115)

    For i = 1 To 12
        Colarr(i) = defaultWidths(i - 1)
        columnHeights(i) = 25
    Next i

    tmp = 0
    
    For i = UBound(rowData) To 1 Step -1
        Set MyTxt = MyCont.Add("Forms.TextBox.1", Cells(iRo, 3 + i - 1).Address, True)

        With MyTxt
            .Move tmp, MyTop, Colarr(i), columnHeights(i)
            .Text = rowData(i)
            .TextAlign = fmTextAlignRight
            .Font.Size = 13
            .Font.Name = "Times New Roman"
            .BorderStyle = fmBorderStyleSingle
            .BorderColor = RGB(128, 128, 128)
        End With
        
        tmp = tmp + Colarr(i) + 0.15
    Next i
    
    Set MyTxt = Nothing
End Sub
Private Sub kh_Add_Labels(MyCont As Control, MyTop As Double)
    Dim i As Integer
    Dim MyLabel As Control
    Dim tmp As Double
    Dim Colarr(1 To 12) As Double
    
    Dim defaultWidths As Variant
    defaultWidths = Array(72, 80, 80, 130, 170, 110, 80, 90, 80, 80, 80, 115)

    For i = 1 To 12
        Colarr(i) = defaultWidths(i - 1)
    Next i

    Dim spacing As Double
    spacing = 0.15

    tmp = 0

    For i = 12 To 1 Step -1
        Set MyLabel = MyCont.Add("Forms.Label.1", "Label" & i, True)
        
        With MyLabel
            .Caption = Worksheets("البداية").Cells(6, 3 + i - 1).Value
            .Move tmp, MyTop, Colarr(i), 20
            .TextAlign = fmTextAlignCenter
            .Font.Size = 14
            .Font.Name = "Times New Roman"
            .BorderStyle = fmBorderStyleSingle
            .BorderColor = RGB(192, 192, 192)
            .BackColor = RGB(51, 204, 204)
        End With
        
        tmp = tmp + Colarr(i) + spacing
    Next i
    Set MyLabel = Nothing
End Sub
Private Sub kh_Find(MyText As String)
    Dim MyHght As Double, MyTp As Double
    Dim Last As Long, ii As Long, i As Long
    Dim Found As Boolean
    Found = False
    MyTp = 0
    
    Application.ScreenUpdating = False
    With Worksheets(Mysh_Name)
        Last = .Cells(.Rows.Count, MyFind_Column).End(xlUp).Row
        
        For ii = 2 To Last
            If CStr(.Cells(ii, MyFind_Column)) Like IIf(Me.Check_Text.Value, "", "*") & MyText & "*" Then
                MyHght = .Rows(ii).RowHeight
                
                Dim rowData(1 To 12) As String
                For i = 3 To 14
                    If i = 4 Or i = 9 Or i = 11 Or i = 12 Or i = 13 Then
                        If IsDate(.Cells(ii, i).Value) Then
                            rowData(i - 2) = Format(.Cells(ii, i).Value, "yyyy/mm/dd")
                        Else
                            rowData(i - 2) = CStr(.Cells(ii, i).Value)
                        End If
                    Else
                        rowData(i - 2) = CStr(.Cells(ii, i).Value)
                    End If
                Next i

                If MyHght < iHeight Then MyHght = iHeight
                
                kh_Add_Controls Me.Frame1, MyTp, MyHght, .Cells(ii, MyFind_Column).Row, rowData
                MyTp = MyTp + MyHght + 2
                Found = True
            End If
        Next
    End With
    
    If Not Found Then
        MsgBox TextBox_Find.Value & " " & "رقم الملف غير موجود", vbExclamation
        Me.TextBox_Find.Value = ""
    End If

    If MyTp >= Me.Frame1.Height Then Me.Frame1.ScrollHeight = MyTp
    Application.ScreenUpdating = True
End Sub

 

 

 

تنسيق الفورم.rar

تم تعديل أكتوبر 19, 2024 بواسطه محمد هشام.

[عادل ابوزيد]

ما شاء الله استاذى الكريم محمد هشام

سلمت يداك وزادك الله من علمه وفضله ورزقه وجزاك الله عنا كل خير وجعله فى ميزان حسناتك واعانكم الله وفرج عنك هموم الدنيا والاخرة

تقبل منى شكرى وحبى وتقديرى