نجوم المشاركات

السلام عليكم 🙂 في الماضي كان عندنا معيار واحد فقط (التاريخ) ، بينما الآن اصبح عندنا معيارين (التاريخ و الادارة) ، وهذا اخذ مني اكثر من يومين للوصول اليه !! على العموم ، نظّفت الكود بطريقة اخرى ، والعرض اصبح الآن يأخذ الصفحة كاملة ، وعلى اساسه يعمل عرض الحقول 🙂 وهذا الكود كاملا: Private Sub Report_Open(Cancel As Integer) Dim ctrl As Control Dim A As Integer Dim Empty_Cells As Integer Dim Full_Cells As Integer Dim W As Integer Dim myWhere As String Dim rpt_width As Integer Dim Full_Date As Date Dim D As Integer Dim Y As Integer Dim M As Integer 'W = 2200 / 4 'field width Empty_Cells = 0 Full_Cells = 0 'the name rpt_width = 0 Y = Forms!Report!iYear 'year M = Forms!Report!iMonth 'month 'lets fit/expand the controld based on the avaible width 'how many Full_Cells For D = 1 To 31 Full_Date = DateSerial(Y, M, D) myWhere = "[edara]='" & Forms!Report!cmd_edara_N & "'" myWhere = myWhere & " And " myWhere = myWhere & "[zeiara_date]=" & DateFormat(Full_Date) A = DCount("*", "zeara", myWhere) If A <> 0 Then Full_Cells = Full_Cells + 1 End If Next D W = Me.Width - (Me.Printer.LeftMargin + Me.Printer.RightMargin + Me("mogh_name").Width) W = W / (Full_Cells - 1) For D = 1 To 31 Full_Date = DateSerial(Y, M, D) 'the field Names from the Crosstab query 'check if this field exists int the table myWhere = "[edara]='" & Forms!Report!cmd_edara_N & "'" myWhere = myWhere & " And " myWhere = myWhere & "[zeiara_date]=" & DateFormat(Full_Date) A = DCount("*", "zeara", myWhere) If A = 0 Then 'field dose not exist Me("txt_" & D).Width = 0 'trim field size to Zero Me("txt_" & D).Visible = False 'make the field invisible Me("txt_" & D).ControlSource = "" 'remove the Control Source Me("lbl_" & D).Width = 0 'trim label size to Zero Me("lbl_" & D).Visible = False 'make the label invisible Empty_Cells = Empty_Cells + 1 'Debug.Print "Off " & Me("txt_" & D).Name & vbTab & "D:" & D & vbTab & "Full:" & Full_Date & vbTab & "A:" & A Else 'field exists Me("txt_" & D).Width = 1 * W 'set the field width Me("txt_" & D).Visible = True 'make the field visible Me("txt_" & D).ControlSource = Full_Date Me("lbl_" & D).Width = 1 * W 'set the label width Me("lbl_" & D).Visible = True 'make the label visible Me("lbl_" & D).Caption = D & "/" & M 'give the label, a caption Full_Cells = Full_Cells + 1 rpt_width = rpt_width + Me("txt_" & D).Width 'add the width 'Debug.Print "ON " & Me("txt_" & D).Name & vbTab & "D:" & D & vbTab & "Full:" & Full_Date & vbTab & "A:" & A End If Next D Me.Width = rpt_width + Me("mogh_name").Width 'the final Report width End Sub جعفر 1030.rpt_Monthly_Crosstaby.mdb

السلام عليكم 🙂 وبعد ملاحقة الرابط الى آخر الى آخر الى آخر الى آخر الى آخر الى آخر الى ... ، ومحاربة مضاد الفيروسات على كمبيوتري مع هذه الصفحات والتي تحاول زرع برامج خبيثة عليه ، اليكم الرابط الاخير لتحميل البرنامج: https://www.file-up.org/azot1x4brsec جعفر ملاحظة: بسبب صعوبة حصول الاعضاء على البرنامج من رابط الرفع ، تم اضافة المرفق الى الموضوع الاصل 🙂

وعليكم السلام. قم بوضع اداة الـ ComboBox اعطها اي اسم مثلا ( Comb_List_Report ) ثم اذهب الى خيارات الكومبوبوكس بيانات > نوع مصدر الصف > قائمة القيم اكتب في حدث Form_Load For Each accObject In CurrentProject.AllReports Me.Comb_List_Report.AddItem accObject.Name Next حسنين

اتفضل الملف لعله يفى بالغرض Sales Rebort.xlsm اضغط على زر يقوم بتجميع البيانات من الشيتات

السلام عليكم أولا أشكر أ/ @ابا جودى على فتح هذا الموضوع وهو بالأهمية بمكان فكل المصالح الحكومية وغيرها قائمة على هذا النظام البدائى فى المراسلات ومن عانى مثلى فى تتبع مراسالة ما خاصة لو كان الأمر متعلق بتاريخ قديم - فسيقدر ولا شك أهمية والحاجة الملحة ولوجود مثل هذه الفكرة التى يطرحا أخونا الغالى. وأشكر لك ثانية دعوتك الكريمة للدخول الى الموضوع - وان كنت أرى أنى لست أهلا لتلك الدعوة - ولكن أحاول قدر جهدى والله المستعان اسمحلى أولا ببعض الاستفسارات: 1- بما أن قسم السكرتارية هو من يستقبل المراسلات ثم يتم تسليمها الى الادارات المختصة بعد - فهل هناك استثناء لتلك القاعة أى أن هناك مراسلات لا يتم تسليمها الى السكرتارية بل توجه للمدير العام مباشرة أو الى جهة ما مباشرة. 2- المراسة الخاصة بجهة ما - هل هناك مختص بتلك الجهة لاستلام المراسلة أو أى شخص بنفس الجهة يمكنه الاستلام (مثلا: لو كانت المراسلة خاصة بقسم الحسابات: هل كاتب القسم هو المسئول عن استلام المراسلات أم أى شخص بالقسم يمكنه الاطلاع على المراسة واستلامها - أم مدير القسم شخصيا- ولا يمكن لأحد ما الاطلاع عليها) 3- هل ينتهى دور قسم السكرتارية بتسليم المراسلات للجهة المختصة فحسب - أم أنه يقوم بمتابعة الموضوع ( بأن تكون حالة المراسة لديه: تم التسليم - قيد التسليم - وفقط ) أم ( قيد التسليم - تم التسليم وبانتظار الرد من الجهة المختصة - تم عمل اللازم بشأن كذا وكذا...) هذا ما يحضرنى الآن - وجزاك الله خيرا فقد اشعلت حماستى لمتابعة الموضوع. ولكن وفى النهاية: أقترح أن المرفقات لا تكون ضمن قاعدة البيانات, بل يتم تخزينها بمجلد بجوار قاعدة بيانات الخلفية ويتم تخزين رابط المرفق فحسب لعدم تضخم قاعدة البيانات وثقلها ووجود صعوبة فى التعامل معها.

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

كثر الحديث والطلب عن هذا الموضوع (استخراج الارقام أو الأحرف او الكلمات من نص) لذلك قمت بتحميل هذا الملف الذي عسى ان يستفيد منه اكبر عدد ممكن من الاعضاء الملف يحتوي على دالّة معرفة Option Explicit Function Salim_Single_Match(aString As String, my_expression As String, n%) As Variant Dim RegEx As New VBScript_RegExp_10.RegExp Dim NowArray() As String Dim Match, matches As Object Dim x%, cnt% With RegEx .Pattern = my_expression .Global = True .IgnoreCase = True End With On Error Resume Next Set matches = RegEx.Execute(aString) x = matches.Count If x = 0 Then Error.Clear Salim_Single_Match = "No Match": Exit Function End If ReDim NowArray(x - 1) For Each Match In matches NowArray(cnt) = Match.Value cnt = cnt + 1 Next If n > cnt Then n = cnt Salim_Single_Match = NowArray(n - 1) End Function salim_UDF_Formula.xlsm

جرب هذا ..... test4.mdb

السلام عليكم, في سنة 2017 قمت بكتابة كلاس بسيط لحماية برنامجي ولضمان برنامجي لا يعمل في غير كومبيوترات في حاله بيعه. مميزات الكلاس: 1- قفل قاعدة البيانات على ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) 2- (استحاله) فك النماذج والتقارير في حال عدم تجاوزك لنموذج ( تسجيل الدخول ) ببساطة ستقول يمكنني العثور على باسورد القاعدة داخل الجدول ( الطريقة المعتادة لدينا جميعا في انشاء نموذج تسجيل دخول ). قبل كل شي ليكن لدينا مثلا جدول اسمة ( tbl_Login ) و نموذج اسمه ( frm_Login ) الجدول لتخزين اسم المستخدم وكلمة المرور والنموذج لعمل تسجيل الدخول عند ذهابنا للجدول ( tbl_Login ) ، سوف نحصل على باسورد مشفر من الجدول لو كان الباسورد مثلا ( 313 ) فإنك ستحصل على ( 701D6068 ) 2- عندما نقوم بتسجيل الدخول في النموذج سيقوم البرنامج بأخذ كلمة السر المدخلة ويقوم بتشفيرها ثم يقوم بمطابقتها مع الباسورد الموجود في الجدول اذا كان الباسورد المُدخل يطابق الجدول سيكتب قيمة معينة runtime ويقوم بازالة جميع القيود من النماذج والتقارير. اولا: كلاس الحماية Option Compare Database '----------------------------------------------------- ' Protection Module Coded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- Public SEMO As String Function SEMO_GET() SEMO = SEMO SEMO_GET = SEMO End Function Function PR() As Boolean PR = False 'False=Disabled , True=Enabled End Function Function HWND_ID() HWND_ID = "3C3F4825" 'Your HWID End Function Function HWND_MSG() HWND_MSG = "...ليست لديك صلاحيات كافية لإستخدام هذا الاجراء" End Function Function KEY_ENDE() KEY_ENDE = "PA$X" End Function Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function Function HWND_PROTECTION() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_PROTECTION = disk.volumeserialnumber Exit For End If Next If HWND_ID = HWND_PROTECTION Then HWND_PROTECTION = "True" Else HWND_PROTECTION = "False" End If End Function 'Code contained within module named mdlforencryptionanddecryption Public Function XORDecryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To (Len(DataIn) / 2) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Val("&H" & (Mid(DataIn, (2 * arkdata1) - 1, 2))) 'The second value comes from the code key intXOrValue2 = Asc(Mid(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) strDataOut = strDataOut + Chr(intXOrValue1 Xor intXOrValue2) Next arkdata1 XORDecryption = strDataOut End Function Public Function XOREncryption(CodeKey As String, DataIn As String) As String Dim arkdata1 As Long Dim strDataOut As String Dim temp As Integer Dim tempstring As String Dim intXOrValue1 As Integer Dim intXOrValue2 As Integer For arkdata1 = 1 To Len(DataIn) 'The first value to be XOr-ed comes from the data to be encrypted intXOrValue1 = Asc(Mid$(DataIn, arkdata1, 1)) 'The second value comes from the code key intXOrValue2 = Asc(Mid$(CodeKey, ((arkdata1 Mod Len(CodeKey)) + 1), 1)) temp = (intXOrValue1 Xor intXOrValue2) tempstring = Hex(temp) If Len(tempstring) = 1 Then tempstring = "0" & tempstring strDataOut = strDataOut + tempstring Next arkdata1 XOREncryption = strDataOut End Function الاستخدام لكل النماذج والتقارير اكتب في حدث Form_Load Option Compare Database Private Sub Form_Load() On Error Resume Next If HWND_PROTECTION = "False" Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim X As Control Set X = Me.Controls.Item(i) X.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If If Protection.SEMO_GET = "SEMO" = False Then MsgBox HWND_MSG, vbCritical, "عملية خاطئة" For i = 0 To Controls.Count - 1 Dim XS As Control Set XS = Me.Controls.Item(i) XS.Visible = False Next DoCmd.Close DoCmd.CloseDatabase DoCmd.Quit End If End Sub الان عندما تريد اعطاء القاعدة لشخص ما قم باعطاءه اولا ملف الـ VBS هذا '----------------------------------------------------- ' ReCoded By Hassanein Hirz Aldeen (SEMO.Pa3x) ' Date 26/11/2017 ' All rights reserved. copyright © 2017 '----------------------------------------------------- ' Get clipboard text Set objHTML = CreateObject("htmlfile") Set Ws = CreateObject("WScript.Shell") Clipboardtext = objHTML.ParentWindow.ClipboardData.GetData("text") sText = HWND_GET 'Set Clipboard Ws.Run "mshta.exe ""javascript:clipboardData.setData('text','" & Replace(Replace(sText, "\", "\\"), "'", "\'") & "');close();""", 0, True MsgBox "Copied!" Function HWND_GET() Set root = GetObject("winmgmts:{impersonationlevel=impersonate}!\\.\root\cimv2") Set disks = root.execquery("select * from win32_logicaldisk") For Each disk In disks If disk.volumeserialnumber <> "" Then HWND_GET = disk.volumeserialnumber Exit For End If Next End Function وظيفة هذا الملف يقوم باستخراج ( رقم الهارد , البروسيسور , المذربورد , الماك أدريس ) ثم ينسخه بعدما يشغله سيقوم العميل باعطاءك هذا الرقم لكي تقوم انت بدورك بوضعه داخل الكلاس في المنطقة Function HWND_ID() HWND_ID = "Your HWID" End Function استبدل كلمة ( Your HWID ) بالرقم الذي سيعطيه لك العميل. ثم بعد ذلك قم بحفظ القاعدة بصيغة ( ACCDE ) واتحدا اي شخص يفتحها مرة اخرى: لكي تفتح النماذج والتقارير عليك بتخطي نموذج تسجيل الدخول ارفقت لكم قاعدة محمية وقاعدة بدون حماية مع ملف الـ VBS الذي يستخرج ارقام قطع الجهاز ويقوم بنسخها،، اتمنى لكم الفائدة جميعاً اهداء الموضوع الى مُعلمي الرائع @jjafferr حسنين Login_SEMO_Pa3x.rar

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

صور بداخل الرسم البيانى بالاكسل الفيديو الصور رابط الملف http://www.mediafire.com/file/abefpdt2r7hvg4v/ادراج+صورة+داخل+الرسم+البيانى.rar

تحويل اللغة تلقائيآ من العربية الى الانكليزية أو العكس بعد الخروج من مربع النص راجيآ القبول و الدعاء لي في ظهر الغيب .. تغيير اللغة تلقائيآ.accdb

جزاك الله خيراً أستاذى @ابو البشر

تفضل ..... test4.mdb

الحمد لله ان تم المطلوب على خير وان فيه اى استفسار اتفضل

السلام عليكم بالمرفق وضعت لك طريقتين كمبوبوكس لعرض اسماء التقارير دون كتابتها وتقوم بعرض التقرير بطريقتين مختلفتين فقط اضغط على زر اظهار التقارير Database3.rar

أولا انت لم تحدد تباعد الاشهر .... لكن انظر المرفق بعد التعديل .... test4.mdb

أخي الكريم جرب أن تجعل مصدر الكومبو SELECT MSysObjects.Name FROM MSysObjects WHERE (((MSysObjects.Type)=-32764));

اتفضل الملف لعله يفى بالغرض لعمل قوائم الفصل.xls

أهلا @محمد احمد لطفى جرب هذا:test2000.mdb

ممكن تستخدم الكود لتقفل الملف ب مفتاح F2 و تقفل الاكسيل بمفتاح F3 مرفق ملف Sub Auto_Open() Application.OnKey "{F2}", "mod_Auto_Open.Close_File" Application.OnKey "{F3}", "mod_Auto_Open.Close_Excel" End Sub Sub Close_File() ThisWorkbook.Save ThisWorkbook.Close End Sub Sub Close_Excel() ThisWorkbook.Save Application.Quit End Sub Auto Close.rar

احسن الله اليك ابا جودي وجزاك الله خير ونفع بك

روائع العلم و الفن استاذ سليم أدامك الله لك كل تقديري و احترامي لعلمك الرائع الله يحميك و يزيدك من علمو

السلام عليكم 🙂 اخي سامي: وضع اكثر من سؤال في الموضوع يُعتبر مخالف لقوانين المنتدى ، والاسئلة اعلاه خارجة عن الموضوع 🙂 جعفر

تفضل هذا ملف ممتاز لأستاذنا الكبير إبراهيم الحداد به ما تطلب كما يمكنك مشاهدة هذا الرابط https://www.officena.net/ib/topic/83108-اظهار-البيانات-بأول-حرف/?tab=comments#comment-528783 بحث بحرف.xlsm

حياك الله اخوتي ابو خليل ، حلبي ، ابو ياسين ، ابو زاهر و وائل جعفر