شوقي ربيع

السلام عليكم تحية كبيرة لاخ ياسر بخصوص قبول TextBox لحروف فقط أو أرقام فقط افضل الاتي 1 لجعل التكست بوكس لاتقبل الا الارقام Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[!0-9]" Then KeyAscii = 0 End Sub 2 لجعل التكست بوكس لاتقبل الا الحرف الانجليزية الصغيرة Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[!a-z]" Then KeyAscii = 0 End Sub 3 لجعل التكست بوكس لاتقبل الا الحروف الانجليزية الكبيرة Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[!A-Z]" Then KeyAscii = 0 End Sub 4 لجعل التكست تقبل الا الحروف الانجليزية الصغيرة والكبيرة معا Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[!A-z]" Then KeyAscii = 0 End Sub 5 لجعل التكست بوكس لا تقبل الا الحروف العربية Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[!أ-ي]" And ChrW(KeyAscii) <> " " Then KeyAscii = 0 End Sub اما اذا كنت تريد تفعيل المسطرة فكل ماعليك هو تلرك فراغ قبل الحرف الأول مثال Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[! A-Z]" Then KeyAscii = 0 End Sub أما اذا اردت تضمين بعض الاشكل كل ما عليك هو ادراج الشكل أو العلامة التي ستسمح بها بين الحرف الاول والمطة هذا مثال لايقبل الا الحروف الانجليزة الكبيرة والمسافة وهته الاشارات =:;/. Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) If ChrW(KeyAscii) Like "[! A=:;/-Z]" Then KeyAscii = 0 End Sub تحياتي للجميع

السلام عليكم مولد نبوي شريف ومبارك وعام سعيد على كل الامة العريبة الشكر موصول للاخ والاستاد العزيز ياسر على الجهد الذي يبذله وكل الاعضاء الذين يشاركون في الموضوع اعتذر عن تأخري في المساهمة في هذا الموضوع المميز وكبداية اقدم هذا الكود البسيط الذي طرحته سابقا في احد طلبات الاعضاء طباعة محتوى اليست بوكس من الفورم Private Sub CommandButton1_Click() Dim Tableau() As Variant: Tableau() = ListBox1.List Dim i As Integer: i = ListBox1.ListCount Dim j As Byte: j = ListBox1.ColumnCount Application.DisplayAlerts = False Workbooks.Add Range("A1:" & Cells(i, j).Address) = Tableau() ActiveWorkbook.PrintOut ActiveWorkbook.Close False Application.ScreenUpdating = True End Sub تحياتي للجميع والى اكواد اخرى ان شاء الله Printe listbox.rar

السلام عليكم جرب هذا Private Sub ComboBox1_Change() Dim i As Byte: i = Me.ComboBox1.ListIndex + 1 Me.TextFind2.Visible = False Me.TextFind1.Visible = False Me.Controls("TextFind" & i).Visible = True End Sub Private Sub ComboBox2_Change() Dim i As Byte: i = Me.ComboBox2.ListIndex + 1 Me.TextFind2.Visible = False Me.TextFind1.Visible = False Me.Controls("TextFind" & i).Visible = True End Sub

السلام عليكم بخصوص لغز تحديد الخلايا ديناميكيا اضن ان هذا الكود يفي بالغرض ActiveSheet.UsedRange.Select اما ان اردت تحديد الخلايا في عمود واحد فقط فعليك بهذا Range(("A1"), Range("A1").End(xlDown)).Select

السلام عليكم هذا حل بخصوص دمج الخلايا و الغاء الدمج مهوش بعيد عن حل الاخ ياسر يشبهلو تقريبا مع شوية تغيرات Sub MergeCells() Dim wSh As Worksheet: Set wSh = ActiveSheet Dim lLrw As Long: lLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row Dim iI As Integer Application.DisplayAlerts = False For iI = 2 To lLrw If wSh.Range("A" & iI - 1) = wSh.Range("A" & iI) Then wSh.Range("A" & iI - 1 & ":A" & iI).Merge Next Application.DisplayAlerts = True End Sub Sub UnMergeCells() Dim wSh As Worksheet: Set wSh = ActiveSheet Dim lLrw As Long: lLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row Dim iI As Integer Application.DisplayAlerts = False For iI = 1 To lLrw If wSh.Range("A" & iI).MergeCells Then wSh.Range("A" & iI).UnMerge: wSh.Range("A" & iI + 1) = wSh.Range("A" & iI) Next Application.DisplayAlerts = True End Sub

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

السلام عليكم ليس لدي ويندوز 64BIT لاجرب الكود لان الطريقة المتبعة في كتابة الاكواد لكي تتناسب مع الاصدرين هي #If VBA7 Then خاص ب 64 bit #Else خاص ب 32 bit #End If جرب هذا الكود المعدل واعلمني بالنتيجة #If VBA7 Then Private Declare PtrSafe Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function SetWindowPos Lib "user32.dll" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As LongPtr Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As LongPtr Private Declare PtrSafe Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr Private Declare PtrSafe Function BringWindowToTop Lib "user32.dll" (ByVal hWnd As Long) As LongPtr Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "User32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As LongPtr #Else Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function GetActiveWindow Lib "user32.dll" () 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 BringWindowToTop Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "User32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long #End If Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 Private Const GWL_EXSTYLE = (-20) Private Const WS_EX_LAYERED = &H80000 Private Const LWA_ALPHA = &H2 Dim hwnd As Long '*************************************************** Private Sub UserForm_Initialize() TextBox1.SetFocus Dim lngWindow As Long, lFrmHdl As Long lFrmHdl = FindWindow(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) End Sub

السلام عليكم ان كنت تبحث عن ابسط كود يفي بالغرض هاك هدا الكود Sub Test() MsgBox Cells.CountLarge End Sub

للافادة كما قال اخي ياسر هذا الكود يعطيك الاصدار و عدد الصفوف وعدد الاعمدة وعدد الخليا Sub Test() Dim wSh As Worksheet: Set wSh = ActiveSheet Dim lRrw As Long: lRrw = wSh.Rows.Count Dim lClm As Long: lClm = wSh.Columns.Count Dim dNRng As Double: dNRng = Val(lRrw) * Val(lClm) Dim sTex As String Select Case Val(Application.Version) Case 9: sTex = "أوفيس 2000" Case 10: sTex = " أوفيس 2002" Case 11: sTex = " أوفيس 2003" Case 12: sTex = " اوفيس 2007" Case 14: sTex = " أوفيس 2010" Case 15: sTex = " أوفيس 2013" End Select MsgBox "الاصدار " & sTex & vbNewLine & _ "عدد الصفوف " & lRrw & vbNewLine & _ "عدد الاعمدة " & lClm & vbNewLine & _ "عدد الخلايا " & dNRng End Sub

السلام عليكم حلو الموضوع هذا كود يعطيك عدد الخلايا في لاي اصدار Sub Test() Dim wSh As Worksheet: Set wSh = ActiveSheet Dim lRrw As Long: lRrw = wSh.Rows.Count Dim lClm As Long: lClm = wSh.Columns.Count Dim dNRng As Double: dNRng = Val(lRrw) * Val(lClm) MsgBox "عدد الخلايا هو " & dNRng End Sub

السلام عليكم بخصوص الاشارة (-) يمكنك استبدالها بماتشاء من هذا الكود For iI = 1 To iLrw If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI) Next اما ان تضع مكانها صورة ؟؟؟؟؟ لاظن ذلك ممكن او ربما ممكن في المثال الاول لانه يعتمد على اكواد html

السلام عليكم بخصوص الاشارة (-) يمكنك استبدالها بماتشاء من هذا الكود For iI = 1 To iLrw If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI) Next اما ان تضع مكانها صورة ؟؟؟؟؟ لاظن ذلك ممكن او ربما ممكن في المثال الاول لانه يعتمد على اكواد html

السلام عليكم الشكر موصول للاخ ibn_egypt وهذا كود مشابه لما تفضل به مع بعض التعديلات Private Sub UserForm_Initialize() Dim wSh As Worksheet: Set wSh = Sheet2 Dim iLrw As Long: iLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row Dim iI As Integer Dim sTex As String For iI = 1 To iLrw If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI) Next HTML sTex, 4, 5 End Sub Private Sub HTML(sTexte As String, iSize As Integer, iScrollAmount As Integer) Me.WebBrowser1.Navigate _ "about:<html><body BGCOLOR ='' scroll='no'><font color= #00000 " & _ " size=" & iSize & " face='Arial'><marquee direction=right ; font-size: 14pt;" & _ " color: white; border-style: ridge; border-color: scrollAmount=" & iScrollAmount & ">" & sTexte & "</marquee></font></body></html>" End Sub ينسخ الكود كما هو في الفورم اما السطر HTML sTex, 4, 5 فيعني على التوالي مايلي النص, حجم الخط, سرعة التحرك اي انه يمكنك التحكم في الخصائص التي سبقة من هذا الكود فقط WebBrowser.rar وهذا حل اخر عن طريق textbox Const cVitesse As Currency = 0.01 Dim bStart As Boolean Sub MovBar() Do While bStart timer_avant = Timer Do While Timer < timer_avant + cVitesse DoEvents Loop sMove Loop End Sub Sub sMove() Dim iWidth As Integer: iWidth = Me.TextBox1.Width Dim iI As Integer For iI = 1 To iWidth timer_avant = Timer Do While Timer < timer_avant + cVitesse DoEvents Loop Me.TextBox1.Left = -iWidth + iI Next End Sub Private Sub UserForm_Activate() bStart = True MovBar End Sub Private Sub UserForm_Initialize() Dim wSh As Worksheet: Set wSh = Sheet2 Dim iLrw As Long: iLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row Dim iI As Integer Dim sTex As String For iI = 1 To iLrw If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI) Next Me.TextBox1 = sTex With Me.TextBox1 .AutoSize = True .BackStyle = 0 .SpecialEffect = 0 End With End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) bStart = False End End Sub textbox.rar تحياتي للجميع

السلام عليكم بنسبة لمحرر الاكواد والفورمة في اوفيس 2013 هي هي مفيش اي اضافات التغيرات الحاصلة اغلبها ع الاكسل او الشيتات ان صح التعبير برغم من انها ليست مختلفة كثيرا على 2010 حسب ما شفت احسن حاجة فيه هي خدمة الدريف او مشاركة الملفات

السلام عليكم اخي ياسر الف مليون مبروك الترقية المستحقة وان شاء الله الى نجاحات اخرى في المنتدى وفي حياتك الشخصية تستاهل كل الخير تقبل مني تحياتي

Private Sub CommandButton1_Click() Dim cTxt As Control Dim iNm As Integer For Each cTxt In Me.Controls If TypeName(cTxt) = "TextBox" Then iNm = iNm + 1 Next MsgBox "Number Textbox this Userform is " & iNm End Sub

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

السلام عليكم الف مبروك الترقية والى المزيد من النجاح والتألق في المنتدى وفي حياتك الخاصة ان شاء الله

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

اخجلتم تواضعنا استاذ ياسر هذا ما طلبت باستخدام فورم قم بتعبئة البيانات الازمة في الشيت وفقط ملاحظة ان كان الرابط موحد عدل في الكود وثبت قيمة المتغير Url فقط تحياتي للجميع HTML.rar

Microsoft HTML Object Library

من هذا الكود حدد اسم الورقة التي تريد فرز بيناتها Dim sh As Worksheet: Set sh = Feuil4'"هذا هو اسم الورقة"

نعم عذرا كان يجب ان انبها بها في الاول Microsoft internet controls

السلام عليكم المشكلة كانت في عدم تعرف الكود على زر التنفيذ و تم حل المشكلة ان شاء الله اما بخصوص عرض النتيجة على متصفح غير الإكسبلورر فلا اعتقد ذلك ممكن لأنه كما تعلم الاوفيس والإكسبلورر نفس المنتجات لنفس الشركة (ميكرو سوفت) لم تكلف نفسها عناء تعريف المتصفحات الاخرى في قاعدة بيانات محرر الاكواد الخاص بالأوفيس على العموم سأحاول ايجاد الطريقة لتنفيذ ذلك (ما لا تفعله ميكروسوفت نفعله ان شاء الله في أوفيسنا) Sub Test() Dim IE Set IE = CreateObject("InternetExplorer.Application") With IE .Visible = True .navigate "http://student.moe.gov.eg/new/serch_students.aspx" Do Until .readyState = 4 DoEvents Loop .document.all.Item("ctl00$ContentPlaceHolder1$TextBox1").Value = "ÇÓã ÇáãÓÊÎÏã" .document.all.Item("ctl00$ContentPlaceHolder1$TextBox2").Value = "ÑÞã ÇáãÓáÓá" .document.all.Item("ctl00$ContentPlaceHolder1$TextBox3").Value = "ßáãÉ ÇáÓÑ" Dim Element As IHTMLElement For Each Element In .document.getElementsByTagName("input") If Element.Type = "submit" Then Element.Click: Exit For Next End With End Sub تحياتي للجميع

السلام عليكم جرب هذا الكود بعدما تقوم بتغير البيانات الازمة واعلمني بالنتيجة Option Explicit Sub Test() Dim IE Set IE = CreateObject("InternetExplorer.Application") With IE .Visible = True .navigate "http://student.moe.gov.eg/new/serch_students.aspx" Do Until .readyState = 4 DoEvents Loop .document.all.Item("ctl00$ContentPlaceHolder1$TextBox1").Value = "اسم المستخدم" .document.all.Item("ctl00$ContentPlaceHolder1$TextBox2").Value = "رقم المسلسل" .document.all.Item("ctl00$ContentPlaceHolder1$TextBox3").Value = "لمة السر" .document.forms(0).submit End With End Sub تحياتي للجميع