Shivan Rekany

اتفضل اليك هذا الكود Private Sub NO_2_BeforeUpdate(Cancel As Integer) Dim MyDcount As Integer Dim MyId As Integer MyId = DLookup("[ID]", "التحويلة", "[رقم التحويلة]=" & Me.NO_2) MyDcount = DCount("*", "التحويلة", "[رقم التحويلة]=" & Me.NO_2) If MyDcount > 0 Then MsgBox "ھذا الرقم محجوزة .. سيتم نقلك اليه" Me.Undo Me.RecordsetClone.FindFirst "[id] = " & MyId Me.Bookmark = Me.RecordsetClone.Bookmark End If End Sub انا عم استخدم اوفيس 2010 وما فيها مشكلة لا تتعصب .. اهتم بصحتك اليك المرفق بعد تعديل --دليل ارقام التحويلات2.rar

يا عذاب الزمان السلام عليكم ورحمة الله وبركاته ما تريد بالضبط هل تريد ان يكون تسلسل التاريخ هكذا s17/00001 ام هكذا s2017/00001 رأيت هذه المشاركة ان استاذنا @jjafferr عطيتك ماتريد

اليكم الملف تم تجربة بنجاح على اوفيس 2010 وعملت بها بعض اضافات و مسحت کود التأکید الانترنیت لأن ما اشتغل عندی حین عدم وجود الانترنیت وعگیت ھدول الرسائل و هذا هو الكود لنموذج التنزيل اوبديت للبرامج Option Compare Database Option Explicit Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef dwflags As Long, ByVal dwReserved As Long) As Long ' لتأکيد على اتصالك بالانترنيت Sub DownloadUpdate() Dim FileNum As Long Dim FileData() As Byte Dim MyFile As String Dim WHTTP As Object Dim str_folder As String Dim fShellRun As Object Set fShellRun = CreateObject("Wscript.Shell") On Error Resume Next Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5") If Err.Number <> 0 Then Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1") End If On Error GoTo 0 MyFile = "https://drive.google.com/drive/folders/0B9STtJY2DhAoQ1JET3F5N3NiMDQ" WHTTP.Open "GET", MyFile, False WHTTP.send FileData = WHTTP.ResponseBody Set WHTTP = Nothing If Dir("C:\MyDownloads", vbDirectory) = Empty Then MkDir "C:\MyDownloads" FileNum = FreeFile Open "C:\MyDownloads\Activation.mde" For Binary As #FileNum Put #FileNum, 1, FileData Close #FileNum DoCmd.OpenForm "frmrisale", acNormal Forms!FrmRisale.TimerInterval = 1000 Forms!FrmRisale!MyTxt.Caption = " [ C:\MyDownloads ]تم تنزيل ملف التفعيل في المسار التالي " Forms!FrmRisale!MyTxt.TopMargin = 100 str_folder = "C:\MyDownloads" ' folder to open Call Shell("explorer.exe " & str_folder, vbNormalFocus) 'DoCmd.Quit End Sub Private Sub Command0_Click() If GetIPAddress <> "127.0.0.1" Then Call DownloadUpdate Else DoCmd.OpenForm "frmrisale", acNormal Forms!FrmRisale.TimerInterval = 1000 Forms!FrmRisale!MyTxt.Caption = "انت غير متصل بالانترنيت .. تأكد من اتصالك بالانترنيت وحاول مجدداً " Forms!FrmRisale!MyTxt.TopMargin = 100 End If End Sub وهذا فانكشن للتأكيد على وجود الانترنيت Option Compare Database Option Explicit Public Const MIN_SOCKETS_REQD As Long = 1 Public Const WS_VERSION_REQD As Long = &H101 Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF& Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF& Public Const SOCKET_ERROR As Long = -1 Public Const WSADESCRIPTION_LEN = 257 Public Const WSASYS_STATUS_LEN = 129 Public Const MAX_WSADescription = 256 Public Const MAX_WSASYSStatus = 128 Public Type WSAData wVersion As Integer wHighVersion As Integer szDescription(0 To MAX_WSADescription) As Byte szSystemStatus(0 To MAX_WSASYSStatus) As Byte wMaxSockets As Integer wMaxUDPDG As Integer dwVendorInfo As Long End Type Type WSADataInfo wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_LEN szSystemStatus As String * WSASYS_STATUS_LEN iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As String End Type Public Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End Type Declare Function WSAStartupInfo Lib "WSOCK32" Alias "WSAStartup" (ByVal wVersionRequested As Integer, lpWSADATA As WSADataInfo) As Long Declare Function WSACleanup Lib "WSOCK32" () As Long Declare Function WSAGetLastError Lib "WSOCK32" () As Long Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long Declare Function gethostname Lib "WSOCK32" (ByVal szHost As String, ByVal dwHostLen As Long) As Long Declare Function gethostbyname Lib "WSOCK32" (ByVal szHost As String) As Long Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Public Function GetIPAddress() As String Dim sHostName As String * 256 Dim lpHost As Long Dim HOST As HOSTENT Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim i As Integer Dim sIPAddr As String If Not SocketsInitialize() Then GetIPAddress = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPAddress = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If sHostName = Trim$(sHostName) lpHost = gethostbyname(sHostName) If lpHost = 0 Then GetIPAddress = "" MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name." SocketsCleanup Exit Function End If CopyMemoryIP HOST, lpHost, Len(HOST) CopyMemoryIP dwIPAddr, HOST.hAddrList, 4 ReDim tmpIPAddr(1 To HOST.hLen) CopyMemoryIP tmpIPAddr(1), dwIPAddr, HOST.hLen For i = 1 To HOST.hLen sIPAddr = sIPAddr & tmpIPAddr(i) & "." Next GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1) SocketsCleanup End Function Public Function GetIPHostName() As String Dim sHostName As String * 256 If Not SocketsInitialize() Then GetIPHostName = "" Exit Function End If If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPHostName = "" MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name." SocketsCleanup Exit Function End If GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1) SocketsCleanup End Function Public Function HiByte(ByVal wParam As Integer) HiByte = wParam \ &H100 And &HFF& End Function Public Function LoByte(ByVal wParam As Integer) LoByte = wParam And &HFF& End Function Public Sub SocketsCleanup() Dim ERROR_SUCCESS If WSACleanup() <> ERROR_SUCCESS Then MsgBox "Socket error occurred in Cleanup." End If End Sub Public Function SocketsInitialize() As Boolean Dim WSAD As WSAData Dim sLoByte As String Dim sHiByte As String Dim ERROR_SUCCESS If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then MsgBox "The 32-bit Windows Socket is not responding." SocketsInitialize = False Exit Function End If If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets." SocketsInitialize = False Exit Function End If If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then sHiByte = CStr(HiByte(WSAD.wVersion)) sLoByte = CStr(LoByte(WSAD.wVersion)) MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets." SocketsInitialize = False Exit Function End If SocketsInitialize = True End Function شکرا لك استاذ @sandanet على هذا الموضوع الرائع شكرا لك استاذنا @أبو عبدالله الحلوانى على المداخلة وشكرا لك استاذنا @jjafferr على مشاركتك .. لان مشاركتك يفرحنا ويعطينا الامل وهذا هو الملف بصيغة mdb تنزيل تحديث في رابط ثابت.rar

جرب ان تكتب في بداية الكود Dim I As Integer والا ارفق نسخة مصغرة من قاعدة بياناتك لعمل علیە او تقدر تستخدم هذا ايضا Function GetNumber(ByVal pStr As String) As Long Dim intLen As Integer Dim n As Integer pStr = Trim(pStr) 'removes leading & trending spaces intLen = Len(pStr) 'stores original length n = 1 'consider this a counter & position marker If pStr = "" Or IsNull(pStr) Or intLen = 0 Then Exit Function 'validate we didn't get passed an empty/null string Do If IsNumeric(Mid(pStr, n, 1)) Then 'check if that single character is a number GetNumber = GetNumber & Mid(pStr, n, 1) 'if it is add to existing ones if any n = n + 1 'add to counter so we know to go to next character on the next pass/loop Else n = n + 1 'it wasn't a number, add to counter so we know to skip it End If Loop Until intLen = (n - 1) 'go until we processed all characters. The reason we have to do n-1 is that Len starts at 0 & we told n to start at 1 End Function 'if no numbers function will return default value of data type, in our case long would be 0 واتفضل اليك هذا بها طريقتين وكلا من طريقتين بيعطينا النتيجة المطلوبة حذف المسافات ويبقى الارقام فقط.rar

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

الیک ھذا تم الحصول علیە من احد مشاركات استاذنا @أبو إبراهيم الغامدي اعمل كوبي باست لهذا الكود الى وحدة نمطية Function GetNumbersOnly(SText) Dim Numbers For i = 1 To Len(SText) If IsNumeric(Mid(SText, i, 1)) Then Numbers = Numbers & Mid(SText, i, 1) End If Next GetNumbersOnly = Trim(Numbers) End Function وفي استعلام اكتب هذا ارقام فقط: GetNumbersOnly([اسم_الحقل])

ھذا فقط تفكير اعمل فولدر وقم بعمل رابط للفولدر وبعدين احتمال ان تقدر تتغير مافي داخلة بنفس الرابط للتجربة : اليك هذا الرابط به صورة فقط https://drive.google.com/drive/folders/0Bw7lKz1UIsW1MEdadDh0OVBWVmM اعمل تنزيل له وبعدين اي بعد تعمل التنزيل راح اعطيك نفس الرابط وبه صور اخر غير هذا

استاذ @خالد أبو هشام اشوف اننا لم نفهم ما تريد ممكن ان تعطينا صورة لمشكلتك لعل وعسى ان نقدر نساعدك اكثر

اھلا بک فی منتداک منتدی اوفیسنا اتفضل اليك هذا الكود للعلم انا غيرت اسم الحقل من Date الى Date1 لان اسم Date محجوزة من قبل اكسس Private Sub Command22_Click() Dim i As Integer Forms!vb1!VB2.SetFocus Forms!vb1!VB2!Date1.SetFocus For i = 0 To Me.sqe - 1 Forms!vb1!VB2!Date1 = DateAdd("M", i, Me.Date1) Forms!vb1!VB2!SELC = Me.sop Forms!vb1!VB2!NOOP = "لم يتم الدفع" DoCmd.GoToRecord , , acNext Next i End Sub واليك المرفق بعد تعديل Database2.rar

اھلا بک فی منتداک منتدێ اوفیسنا یا ھلا وسھلا باذن الله راح نساعدك بقدر مستطاعنا لكن هناك بعض ملاحظات يجب تراعيه اولا : القي نظرتا الى قوانين المنتدى لكي تقدر تسأل سؤال وتحصل على النتيجة باسرع وقت ثانيا : ارفق نسخة مصغرة من قاعدة بياناتك واشرح بالتفصيل ماذا تريد وفي اي نموذج و في اي جدول تريد تقبل تحياتي

استخدم ھذا الكود للتاريخ الميلادي وهو بيشتغل تمام =DCount("*";"المراجعين";"[اسماء الموظفين]= 'سالم' AND [التاريخ] between #16/07/2017# AND #17/07/2017#") لكن لا اعرف لماذا لا يعطي نتائج الصحيحة مع تاريخ الهجري

اتفضل عملت مربعين نصيين لادخال التاريخ فیھما والکود سیکون کالتالی =DCount("*";"المراجعين";"[اسماء الموظفين]='" & "سالم" & "'" & "and [التاريخ]Between [Text598] And [Text600]") والاخر کالتالی =DCount("*";"المراجعين";"[التاريخ] Between [Text598] and [Text600]") عدد الحقول بين تاريخين.rar

اتفضل =IIf([نص582]>[نص580];"+" & ([نص580]/[نص582]);IIf([نص582]<[نص580];"-" & ([نص580]/[نص582]);([نص580]/[نص582]))) لكن هناك اريد اسألك هل تريد ان تعرف نسبة الفرق بين الرقمين بالنسبة المؤية او نسبة المؤوية بين الرقمين ؟ لان الجوابي هو لنسبة المؤيو بين الرقمين وليس نسبة الفرق بين الرقمين بالنسبة المؤوية نسبة الفرق بين رقمين متغيرين.rar

یا ترى ... هل انا فهمت الموضوع خطأ 1 / هل تريد ان تدخل الرقم الباركود في حقل الباركود فقد ؟ 2 / ام تريد ان لا تقدر ان تدخل الرقم الباركود الا بواسطة قارئ الباركود انا ردت على الموضوع لاني كان فهمت المطلوب كانقطة الثانية ممكن توضيح اكثر لكي نفهم لعل وعسى ان يكون هناك شيء لدى من يحب المساعدة

نعم ممكن لكن اريد اعرف عند يكون يساوي تريد تظهر اي علامة بانتظار ردك

هذه احد الحلول غير خاصية النموذج بوب اوب الى نعم كما مبينة في الصورة

اتفضل غيرت حقل اي دي من نوع ترقيم تلقائي الى الرقم وبعدين في نموذج الفرعي في حدث بعد تحديث لحقل سنة كتبت هذا الكود Private Sub elyear_AfterUpdate() Me.id = Nz(DMax("[id]", "raseed", "[nationalty]=" & [Forms]![person]![nationalty]), 0) + 1 End Sub واليك مرفقك بعد تعديل اكتب رقم قومي جديد و اكتب السنة في نموذج فرعي راح تجد التغيير بعد تحديث الاجازات - Copy_2.rar

وفي حال عدم امكنية الجهاز القارئ الباركود لقراءة احد باركودات بسبب من الاسباب , شو تعمل حينئذ ؟ لذلك حسب فهمي من الاحسن ان تستخدم كلا مع البعض وتقدر تتقيد بعض الشروط لكي يكمل العملية مثلا يجب الرقم مكون من .... الارقام او عند ادخال الباركود وذلك الباركود ليس موجود في برامجك ان لا يقبل الادخال وهكذا والله يعلم @jjafferr

مطلوبك ليس واضحة اي سؤالك محتاج للتوضيح اكثر لكي ترى المساهمات الخيرية

السلام عليكم ورحمة الله وبركاته اخي الكريم اذا استخدمت خاصية فورمات Percent لا يحتاج ان تضرب النتيجة في 100 فقط عليك ان تعمل تقسيم الحقل الاول على الثاني ويعطيك النتيجة =[نص580]/[نص582] لكن اذا ما تستخدم الخاصية فورمات Percent واستخدمت مثلا كينرال نمبر حينئذ يجب عليك ان تعمل تقسيم الحقل الاول على الثاني بين قوسين وتضربه في 100 =([Text585]/[Text587])*100 نسبة الفرق بين رقمين متغيرين.rar

السلام عليكم ورحمة الله وبركاته مشاركة مع استاذي القدير جعفر الحبيب على الرعم ان تم الوصول الى النتيجة لكن اريد ان اشارك معكم بطريقة اخرى اتفضل اليك هذا سطر من الكود لكي تعطيه بعد تحديث حقل التاريخ Private Sub date1_AfterUpdate() If Len(Me.Seq & "") = 0 Then Me.Seq = Nz(DMax("[Seq]", "tb1", Left(DMax("[Seq]", "tb1"), 2) = Right(Year([date1]), 2)), Right(Year([date1]), 2) & 0) + 1 Else Exit Sub End Sub 679.ترقيم جديد كل سنة جديدة.rar

الیک ھذا الرابط وهذا احسن من السابق

الیک هذا test122.rar

اتفضل فقط في استعلام مصدر الليست بوكس اضفت هذا كما مبينة في الصورة test1.rar

السلام عليكم ورحمة الله وبركاته اخي محمد انا نزلت المرفقك الرئيسي اللي مع السؤال 1 / ما فيها هذا الخطأ 2 / يظهر هذه الرسالة فقط عند وجود اسم اخر بنفس الاسم وما يظهر لكل من هو جديد نزل مرفقك من جديد وجربه واحكينا ما تراه ونحن ما نرى