خزاني

الدخول ب3 محاولات.وادا كانت لمحاولة ثالثة خطأ يغلق الملف نهائي Private Sub CommandButton1_Click() Static compteur As Byte compteur = compteur + 1 If TextBox1.Value = Sheet1.[A1].Text And TextBox2.Value = Sheet1.[A2].Text Then Unload Me Else If compteur = 3 Then MsgBox "خطاء في كتابةكلمةالسر." & _ vbCrLf & "لايمكنك الدخول للبرنامج" & _ vbCrLf & vbCrLf & "سوف تغادر....", _ vbOKOnly + vbCritical, "كلمةالسر خاطئة" ActiveWorkbook.Close End If MsgBox "كلمةالسرغيرصحيحة." & _ vbCrLf & "ليس لديك الصلاحية للدخول", _ vbOKOnly + vbExclamation, "كلمةالسرخاظئة" TextBox1.Value = "" TextBox2.Value = "" TextBox1.SetFocus Me.Caption = "Entrez le mot de passe. Tentative " & _ compteur + 1 & " sur 3" i = i + 1 If i = 2 Then End End If End If End Sub

مثال تطبيقي: codebarre.rar

بارك الله في جهدك

جزاك الله خيرا اخي في الله

khezzani-barrcode.rar

khezzani-15.rar

السلام عليكم ربط ربما يفيدك http://www.officena.net/ib/index.php?showtopic=59079&hl=

الباركود Module-EAN13 Option Explicit Const KDigits = "0123456789" Const KTbA = "ABCDEFGHIJ", KTbB = "KLMNOPQRST", KTbC = "abcdefghij" Const KTbD = "0123456789", KtbE = "klmnopqrst" Const KCode = "AAAAAAAABABBAABBABAABBBAABAABBABBAABABBBAAABABABABABBAABBABA" Public Const KEAN13 = "EAN13.TTF" Function EAN13$(ByVal Chaine$) Dim Bcle%, Codage$, Check&, Car$ Chaine = Left$(Chaine, 12) If Len(Chaine) < 12 Then Exit Function For Bcle = 1 To 12 Car = Mid$(Chaine, Bcle, 1) If Car < "0" Or Car > "9" Then Exit Function Check = Check + Car * (2 * ((Bcle - 1) Mod 2) + 1) Next Bcle Chaine = Chaine & 10 - (Check Mod 10) Mod 10 EAN13 = Left$(Chaine, 1) & Space$(6) & "*" & Space(6) & "+" Codage = Mid$(KCode, Left$(Chaine, 1) * 6 + 1, 6) For Bcle = 2 To 7 If Mid$(Codage, Bcle - 1, 1) = "A" Then Mid$(EAN13, Bcle, 1) = Mid$(KTbA, Mid$(Chaine, Bcle, 1) + 1, 1) Else Mid$(EAN13, Bcle, 1) = Mid$(KTbB, Mid$(Chaine, Bcle, 1) + 1, 1) End If Next Bcle For Bcle = 8 To 13 Mid$(EAN13, Bcle + 1, 1) = Mid$(KTbC, Mid$(Chaine, Bcle, 1) + 1, 1) Next Bcle End Function Function EAN8$(ByVal Chaine$) Dim Bcle%, Car$, Check% Chaine = Left$(Chaine, 7) If Len(Chaine) < 7 Then Exit Function For Bcle = 1 To 7 Car = Mid$(Chaine, Bcle, 1) If Car < "0" Or Car > "9" Then Exit Function Check = Check + Car * (2 * (Bcle Mod 2) + 1) Next Bcle Chaine = Chaine & 10 - (Check Mod 10) Mod 10 EAN8 = ":" & Space$(4) & "*" & Space(4) & "+" For Bcle = 1 To 4 Mid$(EAN8, Bcle + 1, 1) = Mid$(KTbA, Mid$(Chaine, Bcle, 1) + 1, 1) Next Bcle For Bcle = 5 To 8 Mid$(EAN8, Bcle + 2, 1) = Mid$(KTbC, Mid$(Chaine, Bcle, 1) + 1, 1) Next Bcle End Function

السلام عليكم كود بقوم بحفظ الملف باسم اخر مثل 08/04/2015-1 08/04/2015-2 08/04/2015-3 الى اخره ويتم حفظه فى مكان مسار الملف نفسه Sub test() Dim x As String, i As Byte Do x = Dir(ThisWorkbook.Path & "\" & Format(Date, "yymmdd") & "-" & i + 1 & ".xls") i = i + 1 Loop While x <> "" ThisWorkbook.SaveAs Format(Date, "yymmdd") & "-" & i & ".xls" End Sub كود حفظ الملف بالاسم الذي تختارة في اي قرص Sub copie() nom = InputBox("ادخل الاسم الذي تريده لحفط الملف") chemin = "D:\" ThisWorkbook.SaveAs chemin & nom & ".xls" End Sub كود حفظ بوسطة مربع الحوار Sub Test() Application.Dialogs(xlDialogSaveAs).Show ("C:\") End Sub

تطبيق عملي khezzanifiltre-2015.rar

السلام عليكم و رحمة الله وبركاته كود :عدد مرات ادخال رقم معين في خلية Sub Macro1() On Error Resume Next [val1].ClearContents Range("val").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True Range("E2").Select ActiveCell.FormulaR1C1 = "=SUMPRODUCT(--(val=RC[-1]))" Selection.AutoFill Destination:=Range("val2"), Type:=xlFillDefault Columns("D:D").Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1 End Sub

ما شاء الله عليك أسأل الله لك القبول والخير كله ظاهره وباطنه تقبل تحياتي

السلام عليكم ورحمة الله وبركاته 1- انشاء يوزرفورم وربط الموقع بالانترنات مثال تطبيقي khezzani-Navigate.rar

شكرا للمساهمة واشعت نور للمنتدي

السلام عليكم ورحمة الله وبركاته مثال تطبيقى على الكود المدرج اعلاه khezzani HeureDansCellule.rar

وهذا مثال تطبيقي لتكون راضيا اخي:عماراللهيبي khezzaniFormPhotoOuverture.rar

مشكورالكل فى المساعدة الاخ : عماراللهيبي وهذا مثال بالفيديو khuserform.rar

بارك الله فيك وجزيت خير الجزاء تقبل تحياتي

السلام عليكم ورحمة الله وبركاته اليك هذا الكود ThisWorkbook Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) StopChrono End Sub *--------------------------------------------------- Private Sub Workbook_Open() Chrono End Sub Module1 Option Explicit '--------------------------------------------------------------------------------------- ' Auteur : Ben amar khezzani ' Date : 03/04/2015 ' Sujet : Heure dans Cellule '--------------------------------------------------------------------------------------- Dim Temps As Date Public Sub Chrono() * برمجة الحدث كل ثانية Temps = Now + TimeValue("00:00:01") Application.OnTime Temps, "Chrono" Sheets("ورقة1").Range("D2").Value = Time End Sub Public Sub StopChrono() On Error Resume Next * توقف إدارة الحدث الزمن Application.OnTime Temps, "Chrono", , False On Error GoTo 0 End Sub

بسم الله الرحمن الرحيم Private Sub Workbook_Open() userform1.Show End Sub و يمكن اضافة صورة تكون خلفية للفورم

جزاك الله خيرا على ماتقدمه من اعمال

أخى الحبيب ياسر بارك الله فيك وجزاك الله كل خير

khezzani-1.rar

ملف بالكود khezzani-1.rar

تحديد الزر من البداية الى غاية النهاية ولا يظهر اي ملف فارق Option Explicit Dim y As Byte Private Sub SpinButton1_SpinDown() ActiveCell.Offset(1, 0).Select: es If Selection = "" Then ActiveCell.Offset(-1, 0).Select: es End Sub Private Sub SpinButton1_SpinUp() If Selection = [a2] Then Exit Sub Else ActiveCell.Offset(-1, 0).Select: es End Sub Private Sub UserForm_Initialize() [a2].Select: es End Sub Sub es() For y = 1 To 4: Controls("T" & y) = Cells(Selection.Row, y): Next y End Sub