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

وعليكم السلام ورحمة الله وبركاته هذه الوظيفة تشفر الصورة بنقرة ، وبالنقرة الثانية تفك التشفير يمكنك ادراجها عند جلب الصور وكذلك عند عرضها المهم ان تضعها في مكانها المناسب Private Sub zer1_Click() EcryptDcryptImage ([CurrentProject].[Path] & "\image1" & ".jpg") End Sub Public Sub EcryptDcryptImage(sFileSpec As String) Dim iFle As Long Dim iByteCount As Long Dim i As Long Dim ii As Byte iFle = FreeFile Open sFileSpec For Binary As iFle iByteCount = LOF(iFle) For i = 1 To iByteCount Get iFle, i, ii ii = ii Xor &HFF Put iFle, i, ii Next i Close iFle If UCase$(Right$(sFileSpec, 1)) = "." Then Name sFileSpec As Left$(sFileSpec, Len(sFileSpec) - 1) Else Name sFileSpec As sFileSpec & "." End If End Sub

https://drive.google.com/file/d/16wPjc1F9pyCAZLQN7Ap3qcUOKOZ8bBMa/view?usp=drivesdk البرنامج مضغوط في ملف للتحميل من الرابط ويوضع في قرص D رمز المرور 1 التنزيل من درايف draiv

كود رائع اخوي ابو ابراهيم ، تغوص في الاعماق من مجلد فرعي الى آخر 🙂 جعفر

وعليكم السلام رحمة الله أهلا بك @النجاشي أجريت تعديلا على بعض الإجراءات.. وأنشأت لك وظيفة تقوم بالبحث عن اسم الملف أبتداءً من الدليل الرئيسي إلى أدنى مستوىً من الأدلة الفرعية. فإن كان الملف موجودا؛ أعادة اسم الملف مع الدليل.. الوظيفة مع التعديلات Public Function XPath() XPath = CurrentProject.Path & "\src\" End Function Public Function FSO() As FileSystemObject Set FSO = New FileSystemObject End Function Public Function GetFileDirectory(MainPath As Object, Optional FileName As Variant) Dim OFIL As Scripting.File, OFILS As Scripting.Files Dim OMFD As Scripting.Folder, OSFD As Scripting.Folder Static XFileName As String, FilePath '.. Static Declaration reserved value when function recoll '-- get filename in first time call and reserved value If Not IsMissing(FileName) Then XFileName = FileName End If '-- loop for subfolders in his parent folder For Each OSFD In MainPath.SubFolders Set OMFD = FSO.GetFolder(OSFD.Path) Set OFILS = OSFD.Files '-- loop for file in each folder For Each OFIL In OFILS If OFIL.Name = XFileName Then FilePath = OFIL.Path GoTo TheEnd End If Next '-- Function recoll himself with subfolder GetFileDirectory OSFD Next TheEnd: '-- Function return filepath if file found GetFileDirectory = FilePath End Function اظهار المرفقات .zip

السلام عليكم 🙂 الظاهر هذا موسم الترقيات ، فرجاء تهنئوا معي اخواي @ابو البشر و @kkhalifa1960 على ترقيتهم لرتبة خبير 🙂 لازلنا نبحث لنزيد رصيد المنتدى من الخبراء 🙂 جعفر

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

مرفقك لم يعمل عندي لاني أعمل على أكسس 10 ولكن تفضل ووافني بالرد D912.accdb

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

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

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

هذا الموضوع مهم بالنسبة للمحاسبين ...وبما اني لست محاسبا ومع الاسف فلم اهتم لهذا الموضوع كثيرا انظر هذا الفيديو للاستاذ مؤمن سالم ...واعتقد انه احد اعضاء منتدانا العزيز

عليكم السلام جرب كما في الصورة

مرفقك لم يعمل عندي ولكن ممافهمت تفضل ووافني بالرد D911.accdb

اخي الكريم ... لا تزعل من مناقشتي لك ... فقط ليطمأن قلبي ... والامر متروك لاحد المشرفين ان اذن فأبشر بالباس ننتظر السيد @jjafferr او السيد @أبو إبراهيم الغامدي اعطوني رأيكم حتى لا نخالف قوانين المنتدى

تفضل( مع العلم أن الملف ليس لي ، وأضنه من إبداعات أحد أعضاء المنتدى ) 🙂 : حالة الاتصال بالنت.accdb

تم الحل بفضل الله وانتهت المشكلة والفضل يرجع للأستاذ موسى له منى الف تحية

يخصك ولا تعرف الباس ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ انت تعرف اننا هنا لا ننتهك حقوق البرامج .... لذلك اعطنا دلائل على ان البرنامج يخصك ..... على الاقل لابد انت نسيك الباس للنموذج والتفعيل .... لكن هناك باس على محرر الاكواد هل نسيته ا يضا ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟

جرب هذا الكود اخى Option Explicit '//////////////////////////////////////////////////////////////////// 'Password masked inputbox 'Allows you to hide characters entered in a VBA Inputbox. ' 'Code written by Daniel Klann 'March 2003 'https://stackoverflow.com/questions/28189864/excel-vba-input-box '//////////////////////////////////////////////////////////////////// 'API functions to be used Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _ ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _ (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _ ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long 'Constants to be used in our API functions Private Const EM_SETPASSWORDCHAR = &HCC Private Const WH_CBT = 5 Private Const HCBT_ACTIVATE = 5 Private Const HC_ACTION = 0 Private hHook As Long Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim RetVal Dim strClassName As String, lngBuffer As Long If lngCode < HC_ACTION Then NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lParam End Function Function InputBoxDK(Prompt, Title) As String Dim lngModHwnd As Long, lngThreadID As Long lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title) UnhookWindowsHookEx hHook End Function ولكن من الاسهل كما قال لك اخى @عبدالفتاح في بي اكسيل استخدم userform قم بإنشاء userform يحتوي على مربع نص وزر في خصائص مربع النص ، أدخل * في مربع PasswordChar Box كما بالصورة وفي كود الزر ضع الكود الخاص بك في اول الموضوع

وعليكم السلام ورحمه الله وبركاته اخى @spyhearts ضع هذا في UserForm1 وجرب كتابه اي تاريخ ميلادي سوف يعطيك تاريخ اليوم هجرى اما ان كتبت التاريخ هجري سوف يكتبه لك كما كتبته Private Sub TextBox11_AfterUpdate() If Year(TextBox11.Value) > 1500 Then a = Format(TextBox11.Text, "0") TextBox11.Value = "" MsgBox "هذا ليس تاريخ هجري " VBA.Calendar = vbCalHijri TextBox11.Text = Format(a, "[$-1170000]yyyy-mm-dd;@") End If End Sub وايضا اخى كل طلب يكون له موضوع مستقل ليكون مرجع وللاستفادة المستقبليه للاعضاء

بارك الله فيك استاذي الفاضل@أبو إبراهيم الغامدي ابو ابراهيم وشكر كثير على مجهودك فعلا رائع وجميل وهو المطلوب فالف الف شكر وجزاء الله خير الجزاء وزادك علما تحياتي

بل الشكر لله ثم لكم اخوانى واساتذتى فلولا ما قدمتموه لنا ما تعلمنا شىء فجزاكم الله عنا كل خير 💐🌷 تقبل تحياتى اخى ومعلمى العزيز جعفر

احسنت اخي الكريم @TQTHAMI وجزاك الله خير الجزاء على هذه المشاركة الجميلة.

وعليكم السلام ورحمة الله وبركاته اخى @أبوعيد يوجد موضوع هنا في المنتدى يتحدث عن طلبك هنا وهنا رابط خارجي وايضا هذا الفيديو لعله يفيدك

سيتم النقل لقسم الاكسيل ، للحصول على فرصة اكير للاجابة

وتنسيب البرامج الى صاحبها ، او الى رابط الموضوع اللي كانت فيه 🙂 جعفر

هل قصدك انك تريد تغير دقة شاشة وندوز المستخدم الى 1024*768 . ومع امكانية عمل هذا ، فلا انصح بهذا العمل ، فستصادفك مشاكل اخرى ، وانا من المسخدمين اللي ما اسمح لأحد ان يلعب باعدادات الوندوز في كمبيوتري 🙂 جعفر

بسم الله نبدأ عامنا الحالي بهذه الموسوعة 1200_Visual_Basic_macro_examples.rar عسى أن ينال إعجابكم

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

بعد اذم المهندس قاسم استاذى ومعلمى اتفضل اخى الحل عند طريق دالة DLookUp فى التقرير وليس فى الاستعلام تحياتى 1.rar

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

تم التعديل في الملف المرفق في المشاركة رقم 1 واليك كود اخر يمكنك التعديل عليه ليتوافق مع ملفك الاصلي Sub copy_columns_paste() Dim lr As Integer, MH As Integer, sh1 As Worksheet, sh2 As Worksheet, i As Long Sheet2.Activate 'افراغ البيانات القديمة Range("d10", Range("F" & Rows.Count).End(4)).ClearContents Range("L10", Range("L" & Rows.Count).End(4)).ClearContents Range("N10", Range("N" & Rows.Count).End(4)).ClearContents Set sh1 = Sheet1 Set sh2 = Sheet2 lr = sh1.Cells(Rows.Count, 4).End(xlUp).Row For i = 10 To lr ' تحديد صف بداية النسخ MH = sh2.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row 'العمود المراد ترحيله من شيت 1 _____ العمود المرحل اليه في شيت 2 sh2.Cells(MH, 4) = sh1.Cells(i, 4) sh2.Cells(MH, 5) = sh1.Cells(i, 5) sh2.Cells(MH, 6) = sh1.Cells(i, 6) sh2.Cells(MH, 12) = sh1.Cells(i, 9) sh2.Cells(MH, 14) = sh1.Cells(i, 12) Next i End Sub

شكرا د جمال ...عمل رائع فعلا جعله الله في ميزان حسناتك

شكرا دكتور برنامج سهل متكامل ، الجميل فيه : العمل من خلال شاشة واحدة

افضل طريقة وهي الاسهل بعد تقسيم قاعدة البيانات الى واجهات و جداول خلفية ، يتم آليا اخذ نسخة احتياطية من الجداول عند كل اغلاق للقاعدة او للنموذج الرئيسي

شكرا جزيلا على المشاركة 🙂🌷

شكرا لك دكتور .. ربي يبارك فيك ويجزيك خير الجزاء 😊🌹🌷

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

طيب جرب المرفق حسب فهمي للموضوع ........ قاعدة بيانات.rar

الجدول الذي عليه علامة + سيصبح هو المصدر كما في تقسيم قاعدة البيانات التي تصبح فيها احدى القواعد عبارة عن جداول فقط والقاعدة الثانية فيها النماذج والاستعلامات والتقارير

السلام عليكم مشاركه مع اخوانى واساتذتى جزاهم الله عنا كل خير معلمى العزيز جعفر قد تذكرت لك رد ع موضوع على ما اتذكر كان فى موضوع باسم التقرير الشبح فقمت بتنزيل المرفق والاطلاع عليه ولكن لم اجد الشبح 😀 ولكنى وجدت التالى فالخصائص يتضمن وحده نمطيه مفعله بنعم فقمت بتغييرها الى لا وتم تعديل التقرير والحفظ قمت بالتعديل رقم 4 فقط وركت الاخر تقبلوا تحياتى وجزاكم الله عنا كل خير oiu_1.accdb

السلام عليكم ورحمة الله وبركاته وبها نبدأ اي موضوع اخى @kassem_geo

تفضل اخي Sheet_name.xlsb

وعليكم السلام ورحمة الله وبركاته أتوقع باستخدام الدالة (INDIRECT) ولعل هذا هو المطلوب 😘 نموذج (1).xlsx

هذي النقطة أعتقد ليس لها علاقة بالكود وإنما بتضبيطات بريد الياهو عندك .. فقد حصلت معي سابقا .. ****************************************************************************************** هذا السطر الذي ذكرته لك ( أزل الرمز ( ' ) من أمامه) : وبعد التفعيل تم ارسال المرفق بنجاح : ****************************************************************************************** وبالنسبة لفحص الاتصال بالانترنت استخدم هذا الكود (يوضع في موديول عام) : #If VBA7 Then Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" _ (ByRef dwFlags As Long, _ ByVal dwReserved As Long) As Boolean #Else Private Declare Function InternetGetConnectedState Lib "wininet.dll" _ (ByRef dwFlags As Long, _ ByVal dwReserved As Long) As Boolean #End If Function Is_Connected() As Boolean Dim IEStat As Long Is_Connected = (InternetGetConnectedState(IEStat, 0&) <> 0) End Function Public Sub TestInternetConnection() If Is_Connected() = True Then MsgBox "Connected" Else MsgBox "Not Connected" End If End Sub ثم يتم استدعاء أحد الدالتين التاليتين : Connected() هذه تعطيك نتيجة نعم/ لا على الإتصال TestInternetConnection() وهذه تظهر لك رسالة تخبرك إن كان متصل أم لا ****************************************************************************************** وأنا أريدك أن تتعلم كيفية التعامل مع الأكواد أخي @حمدى الظابط 🙂

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

مجرد تخمين Sub kh_RngProper() Dim Cel As Range Dim ws As Worksheet For Each ws In Worksheets For Each Cel In ws.UsedRange Cel.Value = StrConv(CStr(Cel), vbProperCase) Next Next ws End Sub

المشكلة هيا ان المايكرو يعتمد على موضع الماوس في الحذف لذا هو يحذف ذيل الفاتورة وليس الفاتورة نفسها ,, على العموم احذف الزر الذي قمت بعمله وستخدم زر جديد وضع فيه هذا الكود قمت بتعديل اسم حقل رقم الفاتورة داخل الجدول الى INVOID وايضا قمت بتعديل اسم الحقل في النموذج الى INVONO . نصيحة اخيرة استخدم التسميات الانكليزيه ولا تضع مسافات بين التسميات لانها تسبب كل الكثير من الصداع لو احبب ان تضع مسافه استخدم _ لتجنب المشاكل من هذا النوع , بالتوفيق ان شاء الله On Error Resume Next DoCmd.SetWarnings False DoCmd.RunSQL ("DELETE * FROM فاتورة WHERE [INVOID] = " & Me.INVONO & "") MsgBox "Êã ÍÐÝ ÇáÝÇÊæÑÉ" DoCmd.SetWarnings True Me.Requery

شغل عالى عالى تسلم ايدك ورحم الله والديك ووسع الله فى رزقك

السلام عليكم هذا هو السطر المقصود .Range("A2:S2").AutoFilter Field:=4, Criteria1:=">=" & myDate1, Operator:=xlOr, Criteria2:="<=" & myDate2 تم تغير الجزء xlOr الى xlAnd

السلام عليكم هل تقصد هكذا بحث بين تاريخين.rar