اذهب الي المحتوي
أوفيسنا

برنامج شئون العاملين للاستاذ القدير عبد الباري البنا

محمدي عبد السميع
 مشاركة

الردود الموصى بها

  • 3 weeks later...
محمدي عبد السميع

محمدي عبد السميع

قام بنشر
  • الكاتب
قام بنشر 

Option Explicit

'======================================================
'  اول صف للتقرير
Private Const iRow As Integer = 8
'------------------------------------------------------
'  اسم ورقة التقارير
Private Const Sh_Report As String = "التقرير"
'------------------------------------------------------
'  اسم ورقة البيانات
Private Const Sh_MyDate As String = "data"
'------------------------------------------------------
'  تعيين نطاق الخلايا في ورقة البيانات
'        ويشمل رؤوس الاعمدة
Private Const MyRng_MyDate As String = "A2:z1000"
'======================================================

Private MyRng As Range
Private Num As Integer
Private Const Mycount As Integer = 10

Private Sub CommandButton1_Click()

Dim R As Integer
Application.ScreenUpdating = False
For R = 1 To Num
    If Me.Controls("CheckBox" & R).Value = True Then
        Kh_Start R
    End If
Next
Kh_PageSetup
Application.GoTo Range("A1"), True
Application.ScreenUpdating = True
Unload Me
End Sub
Private Sub Kh_Start(iColumn As Integer)
Dim RCount As Long, C As Integer
C = Cells(iRow, Columns.Count).End(xlToLeft).Column + 1
With MyRng
    RCount = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Cells(1, iColumn).Resize(RCount, 1).Copy
    '  لصق عرض الاعمدة
    Cells(iRow, C).PasteSpecial xlPasteColumnWidths
    '  لصق الفورمات
    Cells(iRow, C).PasteSpecial xlPasteFormats
    '  لصق القيم
    Cells(iRow, C).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
End With
End Sub
Private Sub UserForm_Initialize()
    Dim MyTop As Integer, i As Integer
    Dim MyCBox As Control
    '========================
    kh_MyRngSet
    '========================
    MyTop = 0
    For i = 1 To Num
        Set MyCBox = Frame1.Controls.Add("Forms.CheckBox.1")
        With MyCBox
            .Move 12, MyTop, , , True
            .Alignment = 0
            .Font.Bold = True
            .Caption = MyRng.Cells(1, i).Value
            .Value = True
            .TextAlign = fmTextAlignRight
        End With
        MyTop = MyTop + 24
    Next
    '========================
    With Me
        If Num <= Mycount Then
            .Height = 60 + (24 * Num)
            .Frame1.Height = (24 * Num)
        Else
            .Height = 60 + (24 * Mycount)
            .Frame1.Height = (24 * Mycount)
            .Frame1.ScrollBars = 2
            .Frame1.ScrollHeight = (Num) * 24
        End If
    End With
    '========================
End Sub
Private Sub kh_MyRngSet()
With Sheets(Sh_Report)
    .Select
    .Range(Cells(iRow, 2), Cells(.Rows.Count, .Columns.Count)).Clear
    .PageSetup.PrintArea = ""
End With
With Sheets(Sh_MyDate)
    Set MyRng = .Range(MyRng_MyDate)
End With
Num = MyRng.Columns.Count
End Sub
Private Sub Kh_PageSetup()
Dim Lastrow As Long
Dim LastColumn As Integer
With Sheets(Sh_Report)
    Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
    LastColumn = .Cells(iRow, Columns.Count).End(xlToLeft).Column
    With .PageSetup
        .PrintArea = Range("B2", Cells(Lastrow, LastColumn)).Address
        .zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With
End With
End Sub
Private Sub UserForm_Terminate()
Set MyRng = Nothing
End Sub

البرنامج كنز يحتوي على مجموعه من الاكواد ولا أروع

هذا الكود للعلامه عبد الله باقشير

  • Like 1
محمدي عبد السميع

محمدي عبد السميع

قام بنشر
  • الكاتب
قام بنشر 


Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Const GWL_STYLE = -16
Const WS_CAPTION = &HC00000
Const WS_SYSMENU = &H80000
'======================================================
'======================================================
'     تنسيق التاريخ
Private Const DtF As String = "yyyy/mm/dd"
'======================================================
'     عُرض تاكست الادخال
Private Const iWgt1   As Single = 240
'======================================================
Private Const Frmtop  As Single = 3
Private Const Frmlft  As Single = 3
Private Const iHgt    As Single = 35
Private Const iTop    As Single = iHgt + 2
Private Const mBox    As Long = vbMsgBoxRight + vbMsgBoxRtlReading
'======================================================
Private Ar()          As Integer
Private MyRngSeri     As Range
Private MyRngdate     As Range
Private ContRow       As Long
Private iRow          As Long
Private LastColumn    As Integer
Private tSr           As Boolean
Private MyList        As String
Private tAc           As Boolean
Private iColor1       As Variant
Private iColor2       As Variant


Private Sub BoxFind_Click()
Dim tm As Integer
Me.ListFind.Clear
tm = Me.BoxFind.Tag
Me.Controls("Labeldt" & tm).ForeColor = vbBlack
tm = Me.BoxFind.ListIndex + 1
Me.Controls("Labeldt" & tm).ForeColor = Me.BoxFind.ForeColor
Me.BoxFind.Tag = tm
End Sub
Private Sub ButtonClear_Click()
kh_ClearRecord
End Sub
Private Sub ButtonEnd_Click()
Me.ScrollBar1.Value = ContRow
End Sub
Private Sub kh_ClearRecord(Optional ByVal tcler As Boolean = False)
Dim tm As Integer
''''''''''''''''''''''''''''''''
For tm = 2 To LastColumn
    If tcler Or Me.Controls("Textdt" & tm).Enabled = True Then
        Me.Controls("Textdt" & tm) = ""
    End If
Next
End Sub
Private Sub kh_AddNewRecord()
Dim C As Integer
''''''''''''''''''
Me.Frame1.ScrollTop = 0
kh_ClearRecord True
''''''''''''''''''
Me.LabelSerial = ContRow + 1
Me.LabelSerial2 = ContRow + 1 & "  -  " & ContRow + 1
kh_Enabled False
''''''''''''''''''
With Me.Controls("Textdt1")
    If .Enabled Then
        .SetFocus
        .Text = "يجب الادخال في هذه الخلية افتراضياً"
        .SelStart = 0
        .SelLength = .TextLength
    Else
        .Text = "........"
    End If
End With
End Sub

Private Sub ButtonGo_Click()
With MyRngdate
    .Worksheet.Activate
    .Cells(iRow + 1, Ar(Me.BoxFind.ListIndex + 1)).Select
End With
Unload Me
End Sub

Private Sub ButtonNew_Click()
kh_AddNewRecord
End Sub

Private Sub ButtonNewCancel_Click()
ScrollBar1_Change
End Sub

Private Sub ButtonNewSave_Click()
If kh_TestBlank() Then Exit Sub
Dim cRow As Long: cRow = ContRow + 1
Me.ScrollBar1.Max = cRow
kh_SaveDate cRow, True
Me.ScrollBar1.Value = cRow
Call MsgBox("  تم حفظ السجل الجديد بنجاح  ", mBox, "الحمدلله")

End Sub

Private Sub ButtonPrint_Click()
If Me.Frame1.ScrollHeight > Me.Frame1.Height Then
    Print1
Else
    If MsgBox(" هل تريد طباعة السجل على الفورم  ؟  ", vbYesNo + mBox, "طباعة على الفورم ") = vbYes Then
        Print2
    Else
        Print1
    End If
End If
End Sub

Private Sub Print1()
Dim ctl As Control
Dim i As Integer, t As Boolean
Me.Hide
'------------------------
With Workbooks.Add(xlWBATWorksheet)
    .Activate
    For i = 1 To LastColumn
        Cells(i, "B").Value = CStr(Me.Controls("Labeldt" & i))
        Cells(i, "C").Value = CStr(Me.Controls("Textdt" & i))
    Next
    With Range("B1").Resize(LastColumn, 2)
        .ColumnWidth = IIf(t, 28, 37)
        .Borders.LineStyle = 2
        .WrapText = True
        .VerticalAlignment = xlTop
    End With
    Range("A1").ColumnWidth = IIf(t, 17, 0)
    If t Then AddPrintPicture
    Range("A1").Resize(LastColumn, 3).PrintPreview
    .Close False
End With
'------------------------
Me.Show
End Sub
Private Sub Print2()
Print_Visible False
''''''''''''''''''''''''''
If MsgBox(" هل تريد طباعة الفورم حسب هذه المعاينة ؟  ", vbYesNo + mBox, "معاينة قبل الطباعة") = vbYes Then
    On Error Resume Next
    Me.PrintForm
    On Error GoTo 0
End If
''''''''''''''''''''''''''
Print_Visible True
kh_Enabled True
End Sub

Private Sub Print_Visible(v As Boolean)
Dim ctl As Control
''''''''''''''''''''''''''
If v Then
    Me.BackColor = iColor1
    With Me.Frame1
        .BackColor = iColor2
        .SpecialEffect = 3
    End With
Else
    Me.BackColor = vbWhite
    With Me.Frame1
        .BackColor = vbWhite
        .SpecialEffect = 0
    End With
End If
End Sub

Private Sub ButtonSaveDate_Click()
If kh_TestBlank() Then Exit Sub
kh_SaveDate iRow
ScrollBar1_Change
Call MsgBox("  تم حفظ التغييرات  بنجاح  ", mBox, "الحمدلله")

End Sub

Private Function kh_TestBlank() As Boolean
If Len(Trim(Me.Controls("Textdt1"))) = 0 Then
    kh_TestBlank = True
    Me.Controls("Textdt1").SetFocus
    Call MsgBox("العمود : " & Me.Controls("Labeldt1") & vbCr & vbCr & "يجب الادخال في هذه الخلية افتراضياً", mBox + vbCritical, "استخدام خاطىء")
End If
End Function
Private Sub kh_AutoFill()
Dim CelFill As Range, CFil As Range
Dim R As Integer
''''''''''''''''''''''''''
If tSr Then
    Set CelFill = Union(MyRngSeri, MyRngdate)
Else
    Set CelFill = MyRngdate
End If
''''''''''''''''''''''''''
For R = 1 To CelFill.Areas.Count
    Set CFil = CelFill.Areas(R).Rows(ContRow + 1)
    With CFil
        .AutoFill .Resize(2), xlFillDefault
    End With
Next
Set CelFill = Nothing
Set CFil = Nothing
End Sub

Private Sub kh_SaveDate(ByVal nR As Long, Optional ByVal tFil As Boolean = False)
Dim MyVelue, Msg
Dim C As Integer, cc As Integer
''''''''''''''''''''''''''
'On Error GoTo 1
''''''''''''''''''''''''''
Application.Calculation = xlCalculationManual
''''''''''''''''''''''''''
If nR > 1 And tFil Then kh_AutoFill
If tSr Then MyRngSeri.Cells(nR + 1, 1).Value = nR
'''''''''''''''''''''''''''
For cc = 1 To LastColumn
    C = Ar(cc)
    If Me.Controls("Textdt" & cc).Enabled = True Then
        With MyRngdate
            MyVelue = Me.Controls("Textdt" & cc).Text
            If Not IsNumeric(MyVelue) And IsDate(MyVelue) Then
                MyVelue = Format(MyVelue, DtF)
            Else
                If IsNumeric(MyVelue) And IsDate(.Cells(nR + 1, C)) Then
                    Msg = MsgBox("الخلية في العمود : " & Me.Controls("Labeldt" & cc) & vbCr & vbCr _
                    & "منسقة كتاريخ والادخال الجديد رقم" & vbCr & vbCr _
                    & "هل تريد مسح تنسيقات الارقام السابقة ؟؟", mBox + vbYesNo, "تأكيد مسح تنسيقات التاريخ السابقة ؟؟  ")
                    '''''''''''''''''''''''''
                    If Msg = vbYes Then .Cells(nR + 1, C).NumberFormat = ""
                End If
            End If
            .Cells(nR + 1, C).Value = MyVelue
        End With
    End If
Next

''''''''''''''''''''''''''
1:
Application.Calculation = xlCalculationAutomatic
''''''''''''''''''''''''''

End Sub

Private Sub ButtonExit_Click()
Unload Me
End Sub

Private Sub ButtonDelete_Click()
If MsgBox("  هل تريد حذف السجل رقم : " & iRow & vbCr & vbCr & String$(40, "="), vbCritical + vbYesNo + mBox + vbDefaultButton2, "تاكيد الحذف ") = vbNo Then Exit Sub

If Me.ListFind.ListCount Then Me.ListFind.Clear
MyRngdate.Rows(iRow + 1).EntireRow.Delete
If Not tSr Then GoTo 1
If iRow = ContRow Then GoTo 1
With MyRngSeri
    .Cells(iRow + 1, 1).Value = iRow
    Range(.Cells(iRow + 1, 1), .Cells(ContRow, 1)).DataSeries
End With
1:
Me.ScrollBar1.Max = ContRow - 1
ScrollBar1_Change
Call MsgBox("  تم حذف السجل  بنجاح  ", mBox, "الحمدلله")

End Sub

Private Sub ButtonTop_Click()
If ContRow Then Me.ScrollBar1.Value = 1
End Sub

Private Sub CheckFind_Click()
Me.ListFind.Clear
Me.LblFindCount = 0
End Sub

Private Sub CheckFindDate_Click()
If Me.CheckFindDate.Value = True Then
    kh_SetDate Me.TextFind
    ''''''''''''''''''''''''''''
End If
End Sub


Private Sub CommandButton1_Click()
 ActiveWorkbook.save
 Call MsgBox("  تم حفظ الكل بنجاح  ", mBox, "الحمدلله")
End Sub

Private Sub CommandButton2_Click()
    ChaingeLanguage "Arabic"
    TextFind.SetFocus
End Sub

Private Sub CommandButton3_Click()
   ChaingeLanguage "English"
   TextFind.SetFocus
End Sub

Private Sub CommandButton4_Click()
Me.TextFind.Value = ""
End Sub

Private Sub CommandButton6_Click()
a = Application.Height - 10: b = Application.Width

    With Me
    .Width = .Width * 1.1
    .Height = .Height * 1.1
    .zoom = .zoom * 1.1
    .Top = (a - .Height) / 2
    .Left = (b - .Width) / 2
    End With

End Sub

Private Sub CommandButton7_Click()
a = Application.Height - 10: b = Application.Width

    With Me
    .Width = .Width / 1.1
    .Height = .Height / 1.1
    .zoom = .zoom / 1.1
    .Top = (a - .Height) / 2
    .Left = (b - .Width) / 2
    End With





End Sub

Private Sub LabelH2_Click()
    Call MsgBox(" سيتم تحويل اي قيمة تضعها في مربع النص للبحث " _
        & vbCr & vbCr & "الى تاريخ بالتنسيق الافتراضي للفورم ,,,,,,," _
        & vbCr & String$(40, "=") _
        & vbCr & vbCr & "مع امكانية ادخال رقم صحيح بين 1 الى 31 ليفهم على انه " _
        & vbCr & vbCr & "تاريخ اليوم للشهر الحالي والسنة الحالية " _
        , mBox + vbQuestion + vbApplicationModal, "تعليمات")
    '''''''''''''''''''''''''''

End Sub


Private Sub ListFind_Click()
Dim RR As Long
RR = Me.ListFind.Column(1)
Me.ScrollBar1.Value = RR
End Sub

Private Sub ScrollBar1_Change()
Dim MyVelue
Dim C As Integer, cc As Integer
Me.Frame1.ScrollTop = 0
With Me.ScrollBar1
    If ContRow = 0 Then .Min = 1
    iRow = .Value: ContRow = .Max
End With
'''''''''''''''''
For cc = 1 To LastColumn
    C = Ar(cc)
    With MyRngdate
        If IsDate(.Cells(iRow + 1, C)) Then
            MyVelue = Format(.Cells(iRow + 1, C).Value2, DtF)
            Else: MyVelue = .Cells(iRow + 1, C).Value2
        End If
    End With
    On Error Resume Next
    Me.Controls("Textdt" & cc).Text = ""
    Me.Controls("Textdt" & cc).Text = MyVelue
    On Error GoTo 0
Next
'------------------------------
Me.LabelSerial.Caption = iRow
Me.LabelSerial2.Caption = iRow & "  -  " & ContRow
kh_Enabled True
End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub TextFind_Change()
With Me.ListFind
    If .ListCount Then .Clear
End With
Me.LblFindCount = 0
Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), True, False)
End Sub

Private Sub TextFind_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Me.CheckFindDate.Value = False Then Exit Sub
kh_SetDate Me.TextFind
End Sub

'  هذا الكود يرغمك بادخال تاريخ
Private Sub kh_SetDate(ByVal dCntrl As MSForms.Control)
Dim dtest, dt
dtest = dCntrl
If Not IsDate(dtest) Then
    If IsNumeric(dtest) Then
        On Error Resume Next
        dt = Format(DateSerial(Year(Date), Month(Date), Val(dtest)), DtF)
        If Err Then dt = Format(Date, DtF)
        On Error GoTo 0
    Else
        dt = Format(Date, DtF)
    End If
    Else: dt = Format(CDate(dtest), DtF)
End If
dCntrl = dt
End Sub


Private Sub TextSerial_Change()
Dim v
v = Me.TextSerial.Text
If Len(v) = 0 Then Exit Sub
If Not IsNumeric(v) Then GoTo 1
If v = 0 Or v > ContRow Then GoTo 1
Exit Sub
'=======================
1: Me.TextSerial.Text = Left(Me.TextSerial.Text, Len(Me.TextSerial.Text) - 1)
End Sub

Private Sub TextSerial_AfterUpdate()
If Len(Me.TextSerial) Then Me.ScrollBar1.Value = Me.TextSerial.Value: Me.TextSerial = ""
End Sub

Private Sub kh_Enabled(ByVal Ebl As Boolean)
Me.ButtonNewSave.Visible = Not Ebl
Me.ButtonNewCancel.Visible = Not Ebl
Me.ButtonNew.Visible = Ebl
Me.ButtonSaveDate.Visible = Ebl
''''''''''''''''''''''''''''''''''''''''''''
Me.ButtonPrint.Enabled = Ebl
Me.ButtonSaveDate.Enabled = Ebl
Me.ButtonSerach.Enabled = IIf(Len(Trim(Me.TextFind)), Ebl, False)
''''''''''''''''''''''''''''''''
Me.ButtonEnd.Enabled = CBool(iRow <> ContRow)
Me.ButtonTop.Enabled = CBool(iRow > 0 And iRow <> 1)
Me.ButtonNewCancel.Enabled = IIf(iRow, True, False)
Me.ButtonDelete.Enabled = IIf(ContRow = 1, False, Ebl)
End Sub

Private Sub ButtonSerach_Click()
Dim tb1 As Boolean, ib As Boolean
Dim R As Long, RR As Long
Dim C As Integer
Dim MyFind, MySrch, MyVelue
''''''''''''''''''''''
Me.ListFind.Clear
If Len(Trim(Me.TextFind)) = 0 Then Exit Sub
'''''''''''''''''''''
C = Me.BoxFind.ListIndex + 1
tb1 = CBool(Me.CheckFindDate.Value = True)
If tb1 Then
    If Not IsDate(Me.TextFind) Then kh_SetDate Me.TextFind
    MyFind = CDbl(CDate(Me.TextFind))
    
Else
    MyFind = Me.TextFind.Value
End If
'''''''''''''''''''''''
With MyRngdate.Cells(2, Ar(C))
    For R = 1 To ContRow
        If Len(Trim(.Cells(R, 1))) Then
            If tb1 Then MySrch = .Cells(R, 1).Value2 Else MySrch = .Cells(R, 1).Value
            ib = IIf(Me.CheckFind.Value, InStr(1, MySrch, MyFind, vbTextCompare) = 1, InStr(1, MySrch, MyFind, vbTextCompare))
            If ib Then
                MyVelue = .Cells(R, 1).Value
                If IsDate(MyVelue) Then MyVelue = Format(MyVelue, DtF)
                Me.ListFind.AddItem MyVelue
                Me.ListFind.List(RR, 1) = R
                RR = RR + 1
            End If
        End If
    Next
End With

Me.LblFindCount = Me.ListFind.ListCount
If RR = 0 Then MsgBox " لا توجد نتائج لبحثك هذا  ", mBox, "تنبيه"

'''''''''''''''''''''''''
End Sub

Sub kh_SetAddrss(ByVal MySht As String, ByVal MyAddrs As String, Optional ByVal aSr As String = "")
tSr = TypeName(Evaluate(aSr)) = "Range"
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With ThisWorkbook
    If tSr Then Set MyRngSeri = .Worksheets(MySht).Range(aSr)
    Set MyRngdate = .Worksheets(MySht).Range(MyAddrs)
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With MyRngdate
    ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row
    LastColumn = .Cells.Count
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Col As Range
Dim ii As Integer
ReDim Ar(1 To LastColumn)
For Each Col In MyRngdate.Cells
    ii = ii + 1
    Ar(ii) = Col.Column - MyRngdate.Column + 1
Next
'''''''''''''''''''''''''''
End Sub

Private Function kh_TestType(Rng As Range, Optional iT As Boolean = False) As Boolean
If Not Rng.Comment Is Nothing Then
    MyList = Trim(Replace(Rng.Comment.Text, Chr(10), ""))
    MyList = Replace(MyList, " ", "")
    If TypeName(Evaluate(MyList)) = "Range" Then
        kh_TestType = True
    End If
End If
End Function


Private Sub UserForm_Activate()
Dim MyTop As Double, MyWith As Double, MyScrollHeight As Double
Dim MyBox As Control, MyLabl As Control
Dim t As Integer
Dim tTp As Boolean
Dim MyType As String
'''''''''''''''''''''
If tAc Then Exit Sub
'''''''''''''''''''''
Me.Caption = MyRngdate.Worksheet.Name
MyScrollHeight = (LastColumn * iTop) + (Frmtop * 2)
With Frame1
    If MyScrollHeight > .Height Then
        .ScrollBars = 2
        .ScrollHeight = MyScrollHeight
    End If
End With
MyTop = Frmtop: MyWith = Frame1.InsideWidth - (iWgt1 + (Frmlft * 2))
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For t = 1 To LastColumn
    tTp = kh_TestType(MyRngdate.Cells(1, Ar(t)))
    MyType = IIf(tTp, "Forms.ComboBox.1", "Forms.Textbox.1")
    Set MyBox = Frame1.Controls.Add(MyType, "Textdt" & t, True)
    With MyBox
        .Move Frmlft, MyTop, iWgt1, iHgt
        .TextAlign = 3
        If tTp Then
            .BackColor = 16763955
            .ControlTipText = "إختر من القائمة..تحياتى عبدالبارى البنا"
            On Error Resume Next
            .List = Range(MyList).Value
            If Err Then .AddItem Range(MyList).Cells(1, 1).Value
            On Error GoTo 0
        End If
        If MyRngdate.Cells(2, Ar(t)).HasFormula = True Then
            .BackStyle = 0
            .TextAlign = 2
            .SpecialEffect = 3
            .Enabled = False
        End If
    End With
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Set MyLabl = Frame1.Controls.Add("Forms.Label.1", "Labeldt" & t, True)
    With MyLabl
        .Move iWgt1 + Frmlft, MyTop, MyWith, iHgt
        .SpecialEffect = 3
        .TextAlign = 2
        .Caption = MyRngdate.Cells(1, Ar(t))
    End With
    '''''''''''''''''''''''''''''''''''
    Me.BoxFind.AddItem MyRngdate.Cells(1, Ar(t)).Value2
    MyTop = MyTop + iTop
Next
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Me.BoxFind
    .Style = 2
    .Tag = 1
    .ListIndex = 0
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Me.ScrollBar1
    .Max = ContRow
    If ContRow Then
        .Min = 1
        '.Value = ContRow
    Else
        kh_AddNewRecord
    End If
End With
tAc = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Me.TextBox1.Value = ورقة13.Range("f18").Value
 CheckFind.Value = True
End Sub

Private Sub UserForm_Initialize()
Dim LaCouleur As String
Dim Te
LaCouleur = xlThemeColorLight1
Te = ("&&..الله اكبر..&&   اهلا بكم فى برنامج شئون العاملين بالتربية والتعليم ........................إعداد وتصميم .. عبدالبارى البنا  &&..ولله الحمد..&&")
Me.WebBrowser1.Navigate _
"about:<html><body scroll='no'><font color= " & LaCouleur & " size='4' face='NEW'>" & _
"<marquee direction=right>" & Te & "</marquee></font></body></html>"
'Dim Zo%
'Dim ZH#, ZW#, AL#, AT#, AH#, AW#
'Dim FH!, FW!
'''''''''''''''''''''''
'AH = Application.Height: AW = Application.Width
'AL = Application.Left: AT = Application.Top
'FH = Height: FW = Width
'ZH = AH - FH: ZW = AW - FW: Zo = zoom
'If ZH < ZW Then Zo = Zo * (AH / FH) Else If ZW < ZH Then Zo = Zo * (AW / FW)
'''''''''''''''''''''''
'Move AL, AT, AW, AH
'If Zo <> 100 Then zoom = Zo
'===========================================
iColor1 = Me.BackColor
iColor2 = Me.Frame1.BackColor
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' Me.TextBox1.Value = ورقة13.Range("f18").Value
End Sub

Private Sub UserForm_Terminate()
Set MyRngdate = Nothing
Erase Ar
End Sub


Private Sub WebBrowser1_StatusTextChange(ByVal Text As String)

End Sub

كود اخر ولا في الاحلام

  • Like 1
  • 3 weeks later...
  • 1 month later...
SHEREF ADEL

SHEREF ADEL

قام بنشر
قام بنشر

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept