اذهب الي المحتوي
أوفيسنا

البحث في الموقع

Showing results for tags 'شخابيط'.

  • Search By Tags

    اكتب الكلمات المفتاحيه بينها علامه الفاصله
  • Search By Author

نوع المحتوي


الاقسام

  • الترحيب
  • قسم تطبيقات و لغات مايكروسوفت
    • قنوات تعليمية شخصية و دورات تدريبية مجانية و مدفوعة
    • إعلانات شخصية بأجر للاعضاء
    • المنتدى المفتوح
    • منتدى الاكسيل Excel
    • قسم الأكسيس Access
    • دعم أنظمة الويندوز المختلفة
    • منتدي الوورد Word
    • منتدى الباوربوينت
    • منتدى الاوتلوك Outlook
    • منتدى الفيزيو Visio
    • منتدي مايكروسوفت بروجكت Ms Project
    • منتدى الفرنت بيج العام Frontpage
    • تطبيقات Power Apps
    • وان نوت One Note
    • الناشر بابليشر Publisher
    • Communicator
    • Expression Web
    • SQL Server
    • VB.net
    • C#.net
    • Asp.net
  • الغات و أدوات البرمجة الأخرى
    • حوارات الويب العامة
    • Delphi
    • PHP
    • برمجة الاندرويد
  • أقسام الإدارة و إدارة المشاريع و تطبيقاتها
    • الاستراتيجية وإدارة محافظ المشاريع
    • إدارة المشاريع
    • Scaled Agile SAFe
    • إدارة الجودة
    • القيادة و تنمية المهارات
    • Primavera Enterprise
    • Primavera 3.1
  • البحث العلمي و علوم البيانات
    • مناهج البحث العلمي
    • علم الإحصاء
    • الذكاء الإصطناعي و التنقيب فى البيانات
    • Orange
    • R
    • SPSS
    • Python
  • القسم العام
    • مشاركات المدونات
    • نرحب بزوار الموقع
    • قسم الاقتراحات و الملاحظات
    • أوفيسنا على الفيسبوك

الاقسام

  • VBA Code Library
  • قسم الإكسيل
  • قسم الأكسيس
  • قسم الوورد
  • Project Management
  • Self development التطويرالذاتي
  • EFQM & DGEP
  • معلومات مفيدة
  • أدوات عامة

مدونات

  • M-Taher's Blog
  • مدونة محمد طاهر
  • Officena
  • اا الفاروق اا
  • ‎مدونة أخبار التكنولوجيا
  • M-Taher's Blog
  • يحيى حسين's Blog
  • خبور خير's Blog
  • Dr. AbdelMalek Abu Sheikh's Blog
  • m.hindawi's Blog
  • احمدزمان's Blog
  • الحسامي
  • مدونة أ / محمد صالح
  • yahiaoui's Blog
  • عبدالله المجرب's Blog
  • صيد الخواطر
  • حمادة عمر مدونة
  • مدونة جعفر
  • مدونة عادل حنقي
  • مجدى يونس: لمسة وفاء لمنتدى اوفيسنا
  • Excel Expert Financial&Accounting
  • مدونة اعمال ايقونات الماس لمنتدى اوفيسنا
  • رقائق فى دقائق
  • Shivan Rekany

الاقسام

  • New Features
  • Other

ابحث عن النتائج فى ......

ابحث عن النتائج التي تحوي ....


تاريخ الانشاء

  • بدايه

    End


اخر تحديث

  • بدايه

    End


Filter by number of...

انضم

  • بدايه

    End


مجموعه


Job Title


البلد


الإهتمامات


AIM


MSN


Website URL


ICQ


Yahoo


Jabber


Skype

تم العثور علي 23 نتائج

  1. السلام عليكم ورحمة الله تعالى وبركاته عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ المرفق الاتى ان شاء الله به حل المشكلة تماما طيب ما الفرق بين عمل الاكواد مع خاصية PopUp ان كانت PopUp = True يتم توسيط داخل الشاشة نفسها تبعا لابعاد شاشة العرض نفسها مهما اختلف مقاس الشاشة اما ان كان PopUp = False يتم التوسيط داخل اطار تطبيق الاكس نفسه الاكواد كالاتى اولا كلاس ولابد ان يكون اسم الكلاس clsAutoCenter وان احببتم تغيير الاسم فيجب تعديله فى الاكواد التى تخص الموديول بنفس الاسم الجديد اولا الكلاس : clsAutoCenter '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT 'RECT structure used for API calls. Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI 'POINTAPI structure used for API calls. X As Long Y As Long End Type Private m_hWnd As Long 'Handle of the window. Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window. Private Const m_ERR_INVALIDHWND = 1 Private Const m_ERR_NOPARENTWINDOW = 2 #If VBA7 Then Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long 'Returns the handle of the parent window of the specified window. #Else Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long 'Returns the handle of the parent window of the specified window. #End If Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String) 'Raises a user-defined error to the calling procedure. Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc End Sub Private Sub UpdateWindowRect() 'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow. Dim ptCorner As POINTAPI If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates. If Not Me.Parent Is Nothing Then 'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Left .Y = m_rctWindow.Top End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Left = ptCorner.X .Top = ptCorner.Y End With 'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Right .Y = m_rctWindow.Bottom End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Right = ptCorner.X .Bottom = ptCorner.Y End With End If Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Sub Public Property Get hWnd() As Long 'Returns the value the user has specified for the window's handle. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then hWnd = m_hWnd Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let hWnd(ByVal lngNewValue As Long) 'Sets the window to use by specifying its handle. 'Only accepts valid window handles. If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then m_hWnd = lngNewValue Else RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle." End If End Property Public Property Get Left() As Long 'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Left = m_rctWindow.Left Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Left(ByVal lngNewValue As Long) 'Moves the window such that its left edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Top() As Long 'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Top = m_rctWindow.Top Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Top(ByVal lngNewValue As Long) 'Moves the window such that its top edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Width() As Long 'Returns the current width (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Width = .Right - .Left End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Width(ByVal lngNewValue As Long) 'Changes the width of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Height() As Long 'Returns the current height (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Height = .Bottom - .Top End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Height(ByVal lngNewValue As Long) 'Changes the height of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Get Parent() As clsAutoCenter 'Returns the parent window as a clFormWindow object. 'For forms, this should be the Access MDI window. Dim fwParent As New clsAutoCenter Dim lngHWnd As Long If m_hWnd = 0 Then Set Parent = Nothing ElseIf apiIsWindow(m_hWnd) Then lngHWnd = apiGetParent(m_hWnd) fwParent.hWnd = lngHWnd Set Parent = fwParent Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If Set fwParent = Nothing End Property ثانيا الموديول ولن يفرق اسم الموديول فى شئ '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 ' Call CenterForm(Me) ' Call CenterReport(Me) Sub CenterForm(F As Form) If F.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = F.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf F.PopUp = True Then Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height formAllMarginsWidth = F.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < F.WindowHeight Then formHeight = F.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End If End Sub Sub CenterReport(R As Report) If R.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = R.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf R.PopUp = True Then Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End If End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم استدعاء كود توسيط النماذج من خلال السطر الاتى فى حدث عند الفتح Call CenterForm(Me) ويتم استدعاء كود توسيط التقارير من خلال السطر الاتى فى حدث عند الفتح Call CenterReport(Me) فى حالة كانت PopUp = True يتم توسيط النماذج والتقارير فى وسط شاشة الحاسب الالى تمام تبعا لابعاد الشاشة اما فى حالة PopUp = False يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه والان اليكم المرفق بالمثال العملى AutoCentre.mdb
  2. السلام عليكم ورحمة الله تعالى وبركاته انا بصدد تصميم قاعدة بيانات فى عملى وتباعا ان شاء الله اضع بين اياديكم خلاصة مجهود وتعليم سنوات اولا تسجيل الاخطاء ومعالجتها اولا موديول باسم : basErrorHandling Public strProcessName As String ' The name of the table where errors are logged Public Const TABLE_ERROR_LOG_NAME As String = "tblErrorLog" ' Subroutine to log errors in the error log table Sub ErrorLog(ByVal intErrorNumber As Integer, ByVal strErrorDescription As String, ByVal strErrorProcessName As String) On Error GoTo Err_ErrorLog Dim strErrorMsg As String strErrorMsg = "Error " & intErrorNumber & ": " & strErrorDescription ' Show a message to the user MsgBox strErrorMsg, vbQuestion, strErrorProcessName ' Log error details in the error log table With CurrentDb.OpenRecordset(TABLE_ERROR_LOG_NAME) .AddNew ![ErrorNumber] = intErrorNumber ![ErrorDescription] = Left$(strErrorDescription, 255) ![ErrorProcessName] = strErrorProcessName ![ErrorDate] = Now() ![userName] = GetLoggedUserName() .Update .Close End With Exit_ErrorLog: Exit Sub Err_ErrorLog: ' Error message in case of an unexpected issue strErrorMsg = "An unexpected situation arose in your program." & vbNewLine strErrorMsg = strErrorMsg & "Please write down the following details:" & vbNewLine & vbNewLine strErrorMsg = strErrorMsg & "Calling Proc: " & strErrorProcessName & vbNewLine strErrorMsg = strErrorMsg & "Error Number " & intErrorNumber & vbNewLine & strErrorDescription & vbNewLine & vbNewLine strErrorMsg = strErrorMsg & "Unable to record because Error " & Err.Number & vbNewLine & Err.Description & vbNewLine strErrorMsg = strErrorMsg & "Occurred at Line: " & Erl MsgBox strErrorMsg, vbCritical, "ErrorLog()" Resume Exit_ErrorLog End Sub ' Subroutine to handle and log errors ' This subroutine checks for errors and logs them using the ErrorLog function. ' It clears the error after logging it. ' Parameters: ' - strProcName: The name of the procedure where the error occurred. Public Sub HandleAndLogError(ByVal strProcName As String) ' Check for errors If Err.Number <> 0 Then ' Handle the error and log it Call ErrorLog(Err.Number, Err.Description, strProcName) ' Clear the error Err.Clear End If End Sub ' Function to get the logged username, or return "N/A" if not available Function GetLoggedUserName() As String On Error Resume Next Dim userName As String userName = Environ("USERNAME") If Err.Number <> 0 Then userName = "N/A" Err.Clear End If On Error GoTo 0 GetLoggedUserName = userName End Function ---------------------------------------------------------------------- ثانيا مويدول باسم : basInitialization ' The name of the table where errors are logged Public Const TABLE_ERROR_LOG_NAME As String = "tblErrorLog" ' Subroutine to initialize the application Sub InitializeApplication() ' Initialize the error log table if it doesn't exist If Not IsErrorLogTableInitialized() Then CreateErrorLogTable End Sub ' Check if the error log table exists and is initialized Function IsErrorLogTableInitialized() As Boolean Dim db As DAO.Database Dim rs As DAO.Recordset ' Use error handling to check if the error log table exists On Error Resume Next Set db = CurrentDb Set rs = db.OpenRecordset(TABLE_ERROR_LOG_NAME) On Error GoTo 0 ' Check if the error log table is initialized (contains necessary fields) If Not rs Is Nothing Then On Error Resume Next rs.MoveFirst IsErrorLogTableInitialized = (Err.Number = 0) And (rs.Fields.Count >= 6) On Error GoTo 0 rs.Close End If Set rs = Nothing Set db = Nothing End Function ' Subroutine to create the error log table Sub CreateErrorLogTable() On Error Resume Next Dim db As DAO.Database Set db = CurrentDb ' Check if the table already exists If Not IsTableExists(TABLE_ERROR_LOG_NAME, db) Then ' Define the SQL code to create the table Dim strSQL As String strSQL = "CREATE TABLE " & TABLE_ERROR_LOG_NAME & " (" & _ "ID AUTOINCREMENT PRIMARY KEY, " & _ "ErrorProcessName TEXT(255), " & _ "ErrorNumber LONG, " & _ "ErrorDescription MEMO, " & _ "ErrorDate DATETIME, " & _ "UserName TEXT(255));" ' Execute the SQL command to create the table directly DoCmd.RunSQL strSQL End If Set db = Nothing On Error GoTo 0 End Sub ' Function to check if a table exists in the database Function IsTableExists(tableName As String, Optional db As DAO.Database) As Boolean ' Use DLookup to check for the existence of the table in MSysObjects On Error Resume Next Set db = IIf(db Is Nothing, CurrentDb, db) IsTableExists = Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tableName & "'")) On Error GoTo 0 End Function وظيفة الموديول هو تهئة ما اريد لقاعدة البيانات البدء به ومن خلاله ---------------------------------------------------------------------- 3- نموذج البداية وليكن الان باسم frmInitialization وفى حدث عند التحميل نضع الكود الاتى Private Sub Form_Load() strProcessName = "Form Load : frmIntialization" On Error Resume Next ' Initialize the application when the startup form is loaded. InitializeApplication ' Add calls to the initialized special functions through which you want the database to be booted ' Or add specify the codes through which you would like to process the data later according to the requirements of your design ' Set the current procedure name (you can adjust the procedure name as needed) If Err.Number <> 0 Then ' Handle the error (display a message) Call ErrorLog(Err, Error$, strProcessName) ' Clear the error Err.Clear End If End Sub النتيجة المرغوب فى الخصول عليها : عند تشغيل القاعدة فى المرة الأولى تنشئ جدول تسجيل الأخطاء من تلقاء نفسها باسم الروتين او الحدث ورقم الخطاء والوصف المتطلبات عند اعداد الاكواد تباعا نمرر اسم الروتين من خلال المتغير strProcessName كما فعلت فى الحدث السابق للنموذج: strProcessName = "Form Load : frmIntialization" لو حدث اى خطأ مستقبلا سوف يتم تسجيله حتى يستطيع مطور النظم او القائم على اعمال صيانة قواعد البيانات او المصمم معرفة مكان حدوث الخطأ الشق الثانى نقوم بعمل الايقاف للاخطا ليستكمل الكود عمله حتى لو وجودت اى اخطاء من خلال : On Error Resume Next بعد كتابة الكود كما نريد وبعد ان ننتهى منه نضع الشرط التالى : If Err.Number <> 0 Then بذلك نضع شرط عند الدوران على الكود لتنفيذه فى حالة وجود خطأ اولا اظهر رسالة الخطأ حتى يعلم المستخدم سبب المشكلة ثم استدعى الدالة لتسجيل هذا الخطأ ويتم ذلك من خلال Call ErrorLog(Err, Error$, strProcessName) الان هذه بداية احترافية وعلى اسس صحيحة ومفيدة للمستقبل ..... يتبع HandleAndLogError.accdb
  3. -تجهيز مجلدات وملف الصوت الخطوة الاولى قم بانشاء مجلد جديد فى مسار قاعدة البيانات الحالى باسم ( Resurce ) الخطوة الثانية قم بفتح المجلد السابق وقم بانشاء مجلد جديد بداخله باسم ( Audio Files ) الخطوة الثالثة قم بنسخ ملف صوت الى المجلد ( Audio Files ) اما بامتداد wav , .mp3. --------------------- -تجهيز قاعدة البيانات الخطوة الاولى قم بانشاء وحدة نمطية باسم ( modPlayAudio ) وقم بلصق الاكواد الاتية فى هذه الوحدة النمطية Option Compare Database Option Explicit #If VBA7 And Win64 Then Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare PtrSafe Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #Else Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #End If Const SND_ALIAS_SYSTEMASTERISK As String = "SystemAsterisk" Const SND_ALIAS_SYSTEMDEFAULT As String = "SystemDefault" Const SND_ALIAS_SYSTEMEXCLAMATION As String = "SystemExclamation" Const SND_ALIAS_SYSTEMEXIT As String = "SystemExit" Const SND_ALIAS_SYSTEMHAND As String = "SystemHand" Const SND_ALIAS_SYSTEMQUESTION As String = "SystemQuestion" Const SND_ALIAS_SYSTEMSTART As String = "SystemStart" Const SND_ALIAS_SYSTEMWELCOME As String = "SystemWelcome" Const SND_ALIAS_YouGotMail As String = "MailBeep" ' playsound Params Const SND_LOOP = &H8 Const SND_ALIAS = &H10000 Const SND_NODEFAULT = &H2 ' silence if no sound associated with event Const SND_ASYNC = &H1 ' play async (don't freeze program while sound is playing) Private sMusicFile As String Public soundOn As Boolean Dim mp3Path As String Dim wavPath As String Dim Play As Variant Public Sub Sound_MP3(ByVal File$) sMusicFile = GetShortPath(File) Play = mciSendString("play " & sMusicFile, 0&, 0, 0) If Play <> 0 Then End If End Sub Public Sub Stop_MP3(Optional ByVal FullFile$) Play = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub Public Function GetShortPath(ByVal strFileName As String) As String Dim lngRes As Long, strPath As String strPath = String$(165, 0) lngRes = GetShortPathName(strFileName, strPath, 164) GetShortPath = Left$(strPath, lngRes) End Function Function IsFile(ByVal fName As String) As Boolean On Error Resume Next IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory) End Function Public Function AudioFilePath() As String AudioFilePath = CurrentProject.Path & "\Resurce\Audio Files\" End Function Public Function PlayFile(ByVal FileName_ As String) Dim Msg As String Msg = ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1608) & ChrW(1580) & _ ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(40) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & _ ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) & _ ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & _ ChrW(1608) & ChrW(1580) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & _ ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(1601) & ChrW(1609) & ChrW(32) & ChrW(1575) & _ ChrW(1604) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1605) & _ ChrW(1581) & ChrW(1583) & ChrW(1583) & ChrW(32) & ChrW(46) & ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & _ ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1575) & ChrW(1587) & ChrW(1605) & _ ChrW(32) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & _ ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) mp3Path = AudioFilePath & FileName_ & ".mp3" wavPath = AudioFilePath & FileName_ & ".wav" StopFile If IsFile(mp3Path) Then Sound_MP3 (mp3Path): Exit Function If IsFile(wavPath) Then playSound (wavPath), vbNull, SND_ALIAS Or SND_NODEFAULT Or SND_ASYNC: Exit Function If IsFile(mp3Path) = IsFile(wavPath) Then MsgBox (Msg), vbOKOnly + vbMsgBoxRtlReading + vbMsgBoxRight: Exit Function End Function Public Function StopFile() playSound vbNullString, ByVal 0&, SND_NODEFAULT Stop_MP3 (mp3Path) End Function الخطوة الثانية قم بانشاء نموذج باسم ( frmPlayAudio ) الخطوة الثالثة قم بانشاء مربع نص فى النموذج السابق باسم ( txtAudioFileName ) الخطوة الرابعة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdPlay ) وفى حدث عند النقر ضع الكود الاتى soundOn = True: PlayFile (Me.txtAudioFileName) الخطوة الخامسة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdStop ) وفى حدث عند النقر ضع الكود الاتى StopFile الخطوة السادسة فى حدث عند إغلاق النموذج ضع الكود الاتى StopFile الخطوة السابعة بعد حفظ ما سبق افتح النموذج وادخل فى مربع النص ( txtAudioFileName ) اسم ملف الصوت الموجود فى المسار المحدد بدون الامتداد مثلا لو ملف الصوت باسم : MyAudio.mp3 Or MyAudio.wav اسم ملف الصوت فى مربع النص ( txtAudioFileName ) يكون فى الشكل الاتى فقط : MyAudio والان جرب الضغط على زر الامر الخاص بالتشغيل تارة وزر الامر الخاص بالايقاف تارة أخرى طيب ملاحظة مهمه : الطريقة ودوال API هنا تقوم بتشغيل ملفات صوت من النوعين MP3 . WAV <<---< والله دلع شغل فاخر من الأخر تم صياغة الكود بمرونه مطلقة للتعامل مع الملف بغض النظر عن امتداد الملف اه والله زيمبئولك كده مش مصدق ليه مش بئولك شغل فاخر اللى مش عاجبه المسار لملفات الصوت او عاوز يغير مكانها او اسمها طبعا فى الموديول يغير فى الروتين ده على مزاجه AudioFilePath() انا شرحت بالتفصيل الممل اياك حد يقول لى عاوز مرفق أو مش عارف يطبق الشرح
  4. هل من الممكن تصدير المكتبات المستخدمة في المشروع الى جهاز آخر (أثناء عملية التثبيت مثلاً - على فرض أن المشروع تم تحزيمه بدقة ) حتى لو اختلفت فيه نسخة الأوفيس ؟ كون أن المكتبات هي ملفات معظمها Dll .... الخ من صيغ !!
  5. السلام عليكم ورحمة الله تعالى وبركاته فكرتى المتواضعة أن يكون هذا الموضوع متجدد باستمرار او على الاقل لى شخصيا ليكون بمثابة هامش صغير ليحتوى على شخابيط وافكار وتلميحات هامة ومتعدده ليسهل الوصول اليها لانى الان اتعب جدا جدا جدا جدا فى البحث داخل المنتدى للوصول الى اى معلومة او فكرة قديمة سوف احاول جاهدا جمع أفكارى بصفة مستمرة ليسهل لى او لاحبائى الرجوع اليها مستقبلا .................. على بركة الله
  6. السلام عليكم ورحمة الله تعالى وبركاته طبعا لن اضع افكارى صريحة لتطبيق فكرة محددة لا أنوى أن اعطيكم سمكا بل انوى أن أعلمكم الصيد ... لذلك سوف اضع الاكواد والافكار على وجه العموم وعلى سبيل الشرح ليس الا وليدل كل منكم بدلوه فى التطبيق وليستحضر بنات افكاره كما يترأى له 1- الحماية عن طريق اضافة بيانات الحماية فى الريجسترى نستخدم الأكواد الاتية فى وحدة نمطيه التطبيق فى القاعدة المرفقة .. تم وضع بعض التلميحات على الأكواد Public Const MyRegPath As String = "HKEY_CURRENT_USER\Software\Officena.net" Public Const MyRegKey As String = "Judy" Public Const myStringValue As String = "محمد" Public Const myValueData As String = "ابو جودى" 'returns True if the registry key i_RegKey was found 'and False if not Function RegKeyExists(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'try to read the registry key myWS.RegRead i_RegKey 'key was found RegKeyExists = True Exit Function ErrorHandler: 'key was not found RegKeyExists = False End Function Function RegKeyRead(i_RegKey As String) As String Dim myWS As Object On Error Resume Next 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'read key from registry RegKeyRead = myWS.RegRead(i_RegKey) End Function Function RegKeySave(i_RegKey As String, _ i_Value As String, _ Optional i_Type As String = "REG_SZ") Dim myWS As Object 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'write registry key myWS.RegWrite i_RegKey, i_Value, i_Type End Function Function RegKeyDelete(i_RegKey As String) As Boolean Dim myWS As Object On Error GoTo ErrorHandler 'access Windows scripting Set myWS = CreateObject("WScript.Shell") 'delete registry key myWS.RegDelete i_RegKey 'deletion was successful RegKeyDelete = True Exit Function ErrorHandler: 'deletion wasn't successful RegKeyDelete = False End Function يتبع.. القاعدة المرفقة 01-Dealing with the registry.accdb
  7. السلام عليكم ورحمة الله وبركاته التطبيق اهداء الى منتدانا الحبيب ورواد المنتدى العمل حتى يخرج بهذه الصورة يعلم الله وحده الجهد المبذول به اسال الله تعالى ان يتقبل هذا العمل صدقة جارية الى ما شاء الله تعالى ms access becomes an authorized e-invoicing solution provider in Saudi Arabia by www.officena.net Start your e-invoicing journey حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية يتم قراءة الرمز الناتج ان شاء الله عبر القارىء الرسمي الخاص بالهيئة ( تطبيق جوال ) حمل من هنا : التطبيق الرسمي لهيئة الزكاة والضريبة والجمارك يتم قراءة الرمز الناتج ان شاء الله عبر قارىء خاص ( تطبيق جوال ) حمل من هنا : تطبيق قرائة رمز الاستجابة طبقات لمتطلبات هيئة الزكاة والضريبة والجمارك التطبيق المقدم لكم تمت تجربته وهو متوافق مع النواتين 32 , 64 تم تصميم الاكواد داخل روتين عام ليسهل التعامل معها بكل سهولة ممكنة حاولت جاهدا جمع الاكواد المستخدمة فى موديول ليسهل نقله يتم التعامل مع الروتين باسناد فقط اسماء الحقول من النموذج المستخدم والتى يمكن تغير اسمائها تبعا لتصميمك كالاتى Call CreateInvoice(ID, SellerName, VatNo, TimeStamp, InvoiceWithVat, VatTotal) ID >>-----> اسم الحقل الدال على رقم الفاتورة وهذا ليتم تسمية ملف رمز الاستجابة الناتج بناء عليه SellerName >>-----> اسم الحقل الدال على اسم البائع VatNo >>-----> اسم الحقل الدال على الرقم الضريبي TimeStamp >>-----> اسم الحقل الدال على الوقت وتاريخ انشاء الفاتورة InvoiceWithVat >>-----> اسم الحقل الدال على القيمة الاجمالية للفاتورة VatTotal >>-----> اسم الحقل الدال على القيمة الاجمالية لمبلغ الضريبة فقط بعد تشفير البيانات يتم اسناد الشفرة الى متغير عام باسمstrHashCode والذى من خلاله يت حفظ البيانات المشفرة داخل الجدول تبعا لكل سجل ---------------------------------------------- الية العمل بعد اسناد اسماء الحقول الى الروتين يتم تمرير البيانات من تلك الحقول الى الملف التنفيذى الملحق مع القاعدة والذى بدورة يقوم بانشاء كل من 1- رمز الاستجابة السريع بعد تشفير البيانات طبقا للمطلبات from string to hex to base64 2- انشاء ملف نص به تشفير البيانات بعد ذلك تقوم باقى الاكواد بجلب البيانات المشفرة من ملف النص واسنادها الى المتغير الذى تم تخصيصه لذلك --------------------------------------------- تفاصيل الاكواد داخل الموديول كالتالى الروتين MkDir لعمل المجلدات عند الحاجة دوال الـ API الخاصة بـ ShellWait والمتوافقة مع كلتا النواتان 32 , 64 وتمت التجربة بنجاح على اوفيس 32 تارة واوفيس 64 تارة اخرى بفضل الله بنجاح حيث يتم ارسال البيانات من الحقول الى الملف التنفيذى الملحق من خلال الروتين Shell_n_Wait ليتم انشاء رمز الاستجابة السريع من خلال الروتين الخاص به وهو CreateInvoice وانشاء الملف النصى بجوار الملف التنفيذى فى نفس المسار لالحاق البيانات المشفرة طبقا للمطلبات from string to hex to base64 وبعد ذلك يتم جلب البيانات المشفرة من خلال الروتين ReadFileToText ولابد من استخلاص التشفير من خلال الروتين StripSpChars للاحتفاظ بالنص دون اى زيادات وبعد ذلك يتم الحاق البيانات المشفرة الى المتغير الذى قمت بتخصيصه لذلك وهو يحمل الاسم strHashCode والذى يتم الحاق البيانات من خلاله لكل سجل الى الحقل المخصص به للاحتفاظ بتلك الشفرة حسب طلبات السادة رواد المنتدى الكرام الملف التنفيذى تم عمله من خلال الفيجوال دوت نت ليقوم بتحويل النص طبقا للمطلبات from string to hex to base64 وتم دمج ملفات الـ Dll الخاصة بانشاء رمز الاستجابة بداخل الملف التنفيذى لسهولة التعامل معه من خلال الاكسس ليكون ملف تنفيذى واحد فقط يتم التعامل معه من خلال الـ Command Line دون الحاجة لتثبيت او تسجيل او الاستعانة بأى مكتبات خارجية او حتى ملحقة بالاكسس وذلك لسهولة نقل الموديول الى اى قاعدة دون التقيد باى مكتبات --------------------------------------------- تنبيه هام جدا جدا جدا بجوار قاعدة البيانات فى نفس مسارها مجلد باسم KSA-QR-Tool لايمكن تغيير اسم المجلد والا يحدث خلل وان استدعت الحاجة تغيير الاسم يجب ذلك داخل المدويول يتم كذلك انشاء ملف نصى اليا داخل المجلد KSA-QR-Tool لذلك يجب تحرى الحذر عند محاولة تغيير اسم المجلد داخل الموديول لذلك يرجى عدم محاولة تغير اسم المجلد كذلك داخل المجلد السابق ذكرة الملف التنفيذى KSAQR.exe لا تحاول تغيير اسم الملف لان الاكواد كذلك تتعامل مع هذا الملف من خلال اسمه كذلك لا يمكن نقل المجلد او الملف من مسار قاعدة البيانات الا بالتعديل على الاكواد وفى الختام فضلا وكرما وليس امرا الرجاء الاهتمام بالرد بما يفيد نتيجة تجربتكم الشخصية وتقييم تلك التجربة فلا تبخلوا علينا بذلك... لكم منا خالص الشكر واتمنى لكم تجربة ممتعة ومن يريد طريقتى والتى احبها وافضلها وتعلمتها من استاذى الجليل ومعلمى الجليل الاستاذ @jjafferr بتحميل الملف التنفيذى داخل القاعدة للتأكد دائما من عدم حذفه لا يتردد فى طلب ذلك فقط حاولت تقديم القاعدة بأبسط شكل حتى يقف كل من يريد استخدامها او نقلها الى تطبيقه الخاص على الاكواد المهمة فقط من خلال موديول واحد فقط تيسيرا وتسهيلا عليه وحتى تعم الفائدة هذه الاكواد المستخدمة فى الملف التنفيذى الذى تم انشاؤه من خلال الـ فيجوال دوت نت بناء على رغبة استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل لمن يريد التعلم من اكواد التشفير وبناء على طلب استاذى القدير @ابوآمنة Imports System.Drawing Imports System.IO Imports System.Text Imports QRCoder Module Module1 Sub Main() Try Dim sellerName As String = "" Dim vatNumber As String = "" Dim timeStamp As String = "" Dim invoiceTotal As String = "" Dim vatTotal As String = "" Dim imagePath As String = "" Dim filePath As String = "" If My.Application.CommandLineArgs.Count >= 6 Then sellerName = My.Application.CommandLineArgs(0) vatNumber = My.Application.CommandLineArgs(1) timeStamp = My.Application.CommandLineArgs(2) invoiceTotal = My.Application.CommandLineArgs(3) vatTotal = My.Application.CommandLineArgs(4) imagePath = My.Application.CommandLineArgs(5) filePath = My.Application.CommandLineArgs(6) Else Environment.Exit(0) End If If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, String.Join(" ", sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal), Encoding.UTF8) End If End Dim tlvInvoice = CreateInvoice(sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal) Dim qrGenerator As New QRCodeGenerator() Dim qrData As QRCodeData = qrGenerator.CreateQrCode(tlvInvoice, QRCodeGenerator.ECCLevel.Q) Dim qrCode As QRCode = New QRCode(qrData) Dim qrCodeImage As Bitmap = qrCode.GetGraphic(20) qrCodeImage.Save(imagePath) If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, tlvInvoice, Encoding.UTF8) End If Catch ex As Exception End Try End Sub Function CreateInvoice(sellerName As String, vatNumber As String, timeStamp As String, invoiceTotal As String, vatTotal As String) As String Dim invoiceHex As String = "" For i = 1 To 5 Dim txt As String = "" Select Case i Case 1 txt = sellerName Case 2 txt = vatNumber Case 3 txt = timeStamp Case 4 txt = invoiceTotal Case 5 txt = vatTotal End Select Dim hexTxt As String = StringToHex(txt) Dim hexLen As String = Hex(Encoding.UTF8.GetBytes(txt).Length) If hexLen.Length = 1 Then hexLen = "0" & hexLen End If invoiceHex = invoiceHex & "0" & i & hexLen & hexTxt Next Return HexToBase64(invoiceHex) End Function Function StringToHex(txt As String) As String Dim b As Byte() = Encoding.UTF8.GetBytes(txt) Return BitConverter.ToString(b).Replace("-", "") End Function Function HexToBase64(txt As String) As String Dim bytes = New Byte((txt.Length \ 2) - 1) {} For i = 0 To bytes.Length - 1 Dim mi = txt.Substring(i * 2, 2) bytes(i) = Convert.ToByte(mi, 16) Next i Return Convert.ToBase64String(bytes) End Function End Module E-Invoicing.zip Ksa Qr 32x 64x 2007 to 2021 _Last Version.zip
  8. ذكريات و تحديث اذاعات البث المباشر تحديث المرفق اعادة تفعيل الـ Shift تقليل حجم مستوى الصوت عتج الفتح ازالة روابط اذاعات بث الغناء اخص بكل الشكر والعرفان بالجميل اخى الحبيب الاستاذ @Amr Ashraf لتنبيهى لتدارك خطأى عبر نشر اذاعات بث الغتاء اللهم انى استغفرك واتوب واليك اللهم اغفر لى يارب وارحمتى واعفو عنى يارب العالمين Radio (V2).mdb
  9. السلام عليكم ورحمة والله تعالى وبركاته طيب ببساطه انظر للسلسلة النصية الاتية "Moh8202281012343434" ونريد التعديل عليها لتظهر بهذا الشكل "Moh-820-228-101-234-343-4" او بهذا الشكل "Moh,820,228,101,234,343,4" او بهذا الشكل Moh820/228101/234343/4 يتم عمل ذلك من خلال الكود الاتى Function ReFormat(ByVal strText As String, Optional strSymbol As String = "-", Optional intCountDigits As Integer = 3) Dim i As Long ReFormat = "" For i = 0 To Len(strText) - 1 Step intCountDigits If i = 0 Then ReFormat = Mid(strText, i + 1, intCountDigits) Else ReFormat = ReFormat & strSymbol & Mid(strText, i + 1, intCountDigits) End If Next i End Function syntax code ReFormat(string ,Symbol, Count Digits) Result By default syntax used ReFormat(string) Symbol >-->> - Count Digits >-->> 3 اذا من خلال استدعاء الكود عن طريق البنية المفضلة الاتية: ReFormat(string) تحصل على اضافة العلامة - بعد كل 3 مواضع فى السلسلة النصية اما اذا اردت التعديل فى شكل الرمز وعدد المواضع يمكنك استخدام الكود الاتى : ReFormat(string ,Symbol, Count Digits) مثلا لو اردت استخدام الرمز $ بدلا من الرمز - وتريد وضع الرمز فى السلسلة النصية بعد كل خمس مواضع يكون الكود كالأتى: ReFormat(string ,"$", 5)
  10. السلام عليكم ورحمة الله تعالى وبركاته يسأل البعض عن عدم حفظ البيانات الإ بإستكمال الحقول المطلوبة يمكن ذلك من خلال الفكرة الاتية ولكن بشرط اسم العنصر المطلوب ( الاجبارى) يجب وضع الرمز * فى الـ Tag الخاصة به كما بالصورة الاتية لاننى وضعت الاكواد فى الموديول تعتمد عليها والان الاكواد داخل الموديول 'RequiredData Function RequiredData(ByVal frm As Form) On Error Resume Next Dim ctl As Control Dim err As Integer For Each ctl In frm.Controls Select Case ctl.ControlType Case acTextBox, acComboBox, acListBox, acCheckBox, acOptionButton, acOptionGroup: 'If ctl.StatusBarText = "*" Then If ctl.Tag = "*" Then If IsNull(ctl) Or ctl = "" Or ctl = Null Then ctl.BackColor = 15531489 ctl.SetFocus err = err + 1: MsgBox "Please fill in the " & ctl.Controls(0).Caption: Exit Function Exit For Exit Function Else ctl.BackColor = 16777215 End If End If End Select Set ctl = Nothing Next ctl End Function ويتم استدعاء الكود من خلال Call RequiredData(Me) اترككم مع الاستمتاع بالتجربـة وفى انتظار ارائكم Required data (2).mdb
  11. بداية دعونا نتفق طالما فكرنا فى الموضوع ده ووصلنا له اذن نريد اضافة حماية لتطبيقاتنا طالما سوف نتحدث عن الحماية فلسوف يتم ان شاء الله العمل على افكار تطبيق ذلك خطوة بعد خطوة تدريجيا للارتقاء بالتوازى برفع مستوى الحماية مع الانتهاء من التطبيق مشروحا خطوة بعد خطوة تفصيليا 1- كل اسماء الجداول والنماذج والاستعلامات والموديول التى تخص المستخدمين ونظام الحماية سوف تبدأ بالمقطع Usys حتى يتعامل معها االاكسس على انها من كائنات النظام فيخفيها اليا عن المستخدم العادى 2- تشفير / فك تشفير البيانات التى تخص تطبيق نظام الصلاحيات وبما اننا سوف نبدأ بتلك الجزئية يستوجب تقديم الشكـر والامتنان لاستاذى الجليل ومعلمى القدير الدكتور @SEMO.Pa3x لاننى ان شاء الله سوف استخدم نظام التشفير الذى تقدم به استاذى الجليل اولا ـــــــــ الروتين المستخدم فى تشفير الكلمات والذى يتم وضعه فى موديول Function Encoder(ByVal strWordDecrypt As String) As String Dim iIndex As Integer Dim iEncoder As Integer Dim iEncodedVal As Integer Randomize Encoder = "" For iIndex = 1 To Len(strWordDecrypt) Do iEncoder = Int(98 * Rnd + 89) iEncodedVal = Asc(Mid(strWordDecrypt, iIndex, 1)) Xor iEncoder Loop While iEncodedVal = 1000 Or iEncodedVal < 99 Encoder = Encoder & Chr(iEncodedVal) & Chr(iEncoder) Next iIndex End Function ويتم استدعاءه كلاتى Encoder(text) حيث ان text هو النص المراد تشفيره أو انه اسم الحقل ( تيكست بوكس , كمبو بوكس ..) المراد تشفير القيم الموجوده بهم ------------------- العملية العكسية وهى فك تشفير الكلمات واعادتها الى وضعها الطبيعى الروتين المستخدم فى فك تشفير الكلمات والذى يتم وضعه فى موديول Function Decodeder(ByVal strWordEncrypt As String) As String Dim iIndex As Integer Dim iDecodedVal As Integer Decodeder = "" For iIndex = 1 To Len(strWordEncrypt) Step 2 iDecodedVal = Asc(Mid(strWordEncrypt, iIndex, 1)) Xor Asc(Mid(strWordEncrypt, iIndex + 1, 1)) Decodeder = Decodeder & Chr(iDecodedVal) Next iIndex End Function ويتم استدعاءه كلاتى Decodeder(EncoderText) حيث ان EncoderText هو النص المشفر المراد فك تشفيره أو انه اسم الحقل ( تيكست بوكس , كمبو بوكس ..) المراد فك تشفير القيم الموجوده بهم واخيرا المرفق Encrypt&Decrypt.mdb
  12. السلام عليكم ورحمة الله تعالى وبركاته احيانا نريد التأكد من وجود قيمة محددة فى حقل محدد داخل جدول محدد وذلك حتى نتأكد من عدم حدوث تكرار وطبعا كالعادة سوف اقدم لكم اليوم فكرتى المتواضعة فى هذا الشأن من خلال استخدام وظيفة عامة تعمل كروتين من خلال وحدة نمطية بحيث يتم اسناد القيم التى تخص كل من القيمة واسم الحقل واسم الجدول الى متغيرات عامة ليتم الفحص يعنى مثل ما سوينا من قبل مع المعرف الخاص البرمجى هنا فى هذا الموضوع '|-----------------------------------------------------------| '|---15/09/1443-------16/04/2022_____________________________| '|___www.officena.net________________________________________| '| | '| _ +-----------officena-----------+ _ | '| /o) | ||||| | (o\ | '| / / | @(~O^O~)@ | \ \ | '| ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| (\\\ \_/ / \ \_/ ///) | '| \ / \ / | '| \____/________Mohammed Essam________\____/ | '| 15/09/1443 | '| 16/04/2022 | '| | '|_____www.officena.net______________________________________| '|_____Thank you for visiting https://www.officena.net_______| '|-----------------------------------------------------------| '======Check Input Exist By Input Type======================================================================================================================================' ' ____ __ ____ ____ __ ____ ____ __ ____ ______ _______ _______ __ ______ _______ .__ __. ___ .__ __. _______ .___________. ' ' \ \ / \ / / \ \ / \ / / \ \ / \ / / / __ \ | ____|| ____|| | / || ____|| \ | | / \ | \ | | | ____|| | ' ' \ \/ \/ / \ \/ \/ / \ \/ \/ / | | | | | |__ | |__ | | | ,----'| |__ | \| | / ^ \ | \| | | |__ `---| |----` ' ' \ / \ / \ / | | | | | __| | __| | | | | | __| | . ` | / /_\ \ | . ` | | __| | | ' ' \ /\ / \ /\ / \ /\ / __| `--' | | | | | | | | `----.| |____ | |\ | / _____ \ __| |\ | | |____ | | ' ' \__/ \__/ \__/ \__/ \__/ \__/ (__)\______/ |__| |__| |__| \______||_______||__| \__| /__/ \__\ (__)__| \__| |_______| |__| ' ' ' '===========================================================================================================================================================================' Public Function CheckInputExist( _ ByRef strFieldName As String, _ ByRef strTableName As String, _ ByVal strObjectContainFieldValue) As Boolean On Error GoTo ErrorHandler Dim strFormName As Access.Form Dim stLinkCriteria As String Dim strMsgTitel As String Dim strMsgPrt1 As String Dim strMsgPrt2 As String Dim strErrMsgTitel As String Dim strErrMsg As String Set strFormName = Screen.ActiveForm strMsgPrt1 = ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1593") & ChrW("1579") & ChrW("1608") & ChrW("1585") & ChrW("32") & ChrW("1593") & ChrW("1604") & ChrW("1609") & ChrW("32") & ChrW("46") & ChrW("46") & ChrW("13") & ChrW("10") & ChrW("40") & ChrW("160") strMsgPrt2 = ChrW("32") & ChrW("41") & ChrW("13") & ChrW("10") & ChrW("1587") & ChrW("1608") & ChrW("1601") & ChrW("32") & ChrW("1610") & ChrW("1578") & ChrW("1605") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1606") & ChrW("1578") & ChrW("1602") & ChrW("1575") & ChrW("1604") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1609") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1587") & ChrW("1580") & ChrW("1604") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1606") If Len(strObjectContainFieldValue) = 0 Or IsNull(strObjectContainFieldValue) Then Exit Function Select Case FieldTypeName(strFieldName, strTableName) Case Is = "Text": stLinkCriteria = strFieldName & "= '" & strObjectContainFieldValue & "'" Case Is = "Date/Time": stLinkCriteria = strFieldName & "= #" & Format(strObjectContainFieldValue, "dd/mm/yyyy") & "#" Case Is = "Long Integer": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Integer": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Byte": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Single": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Double": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue Case Is = "Decimal": stLinkCriteria = strFieldName & "=" & strObjectContainFieldValue End Select If DCount("*", strTableName, stLinkCriteria) > 0 Then MsgBox$ strMsgPrt1 & strObjectContainFieldValue & strMsgPrt2, vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading, "" strFormName.Undo strFormName.Recordset.FindFirst stLinkCriteria Else End If procDone: Exit Function ErrorHandler: strErrMsgTitel = ChrW("1582") & ChrW("1591") & ChrW("1571") & ChrW("32") & ChrW("1601") & ChrW("1609") & ChrW("32") & ChrW("1606") & ChrW("1608") & ChrW("1593") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1576") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") strErrMsg = ChrW("1604") & ChrW("1602") & ChrW("1583") & ChrW("32") & ChrW("1581") & ChrW("1575") & ChrW("1608") & ChrW("1604") & ChrW("1578") & ChrW("32") & ChrW("1573") & _ ChrW("1583") & ChrW("1582") & ChrW("1575") & ChrW("1604") & ChrW("32") & ChrW("1606") & ChrW("1608") & ChrW("1593") & ChrW("32") & ChrW("1576") & ChrW("1610") & _ ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") & ChrW("32") & ChrW("1594") & ChrW("1610") & ChrW("1585") & ChrW("32") & ChrW("1589") & ChrW("1581") & _ ChrW("1610") & ChrW("1581") & ChrW("46") & ChrW("46") & ChrW("46") & ChrW("13") & ChrW("10") & ChrW("32") & ChrW("1606") & ChrW("1608") & ChrW("1593") & _ ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") & ChrW("32") & ChrW("1575") & _ ChrW("1604") & ChrW("1605") & ChrW("1587") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1605") & ChrW("32") & ChrW("1607") & ChrW("1608") & ChrW("32") & _ ChrW("40") & ChrW("32") & FieldTypeName(strFieldName, strTableName) & ChrW("32") & ChrW("41") & ChrW("13") & ChrW("10") & ChrW("1605") & ChrW("1606") & ChrW("32") & _ ChrW("1601") & ChrW("1590") & ChrW("1604") & ChrW("1603") & ChrW("32") & ChrW("1602") & ChrW("1605") & ChrW("32") & ChrW("1576") & ChrW("1573") & ChrW("1583") & _ ChrW("1582") & ChrW("1575") & ChrW("1604") & ChrW("32") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") & ChrW("32") & _ ChrW("1578") & ChrW("1578") & ChrW("1591") & ChrW("1575") & ChrW("1576") & ChrW("1602") & ChrW("32") & ChrW("1605") & ChrW("1593") & ChrW("32") & ChrW("1606") & _ ChrW("1608") & ChrW("1593") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1576") & ChrW("1610") & ChrW("1575") & ChrW("1606") & ChrW("1575") & ChrW("1578") _ & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1605") & ChrW("1587") & ChrW("1578") & ChrW("1582") & ChrW("1583") & ChrW("1605") Select Case Err.Number Case Is = 2471: MsgBox$ strErrMsg, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, strErrMsgTitel Case Is = 3075: MsgBox$ strErrMsg, vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, strErrMsgTitel Case Else MsgBox$ Err.Number & ": " & Err.Description End Select Resume procDone End Function Public Function FieldTypeName(ByRef strFieldName As String, ByRef strTableName As String) As String Dim db As DAO.Database Dim objRecordset As DAO.Recordset Dim i As Integer Set objRecordset = CurrentDb.OpenRecordset(strTableName) For i = 0 To objRecordset.Fields.Count - 1 If strFieldName = objRecordset.Fields(i).Name Then Dim strReturn As String Select Case CLng(objRecordset.Fields.Item(i).Type) 'fld.Type is Integer, but constants are Long. Case dbBoolean: strReturn = "Yes/No" ' 1 Case dbByte: strReturn = "Byte" ' 2 Case dbInteger: strReturn = "Integer" ' 3 Case dbLong ' 4 If (objRecordset.Fields.Item(i).Attributes And dbAutoIncrField) = 0& Then strReturn = "Long Integer" Else strReturn = "AutoNumber" End If Case dbCurrency: strReturn = "Currency" ' 5 Case dbSingle: strReturn = "Single" ' 6 Case dbDouble: strReturn = "Double" ' 7 Case dbDate: strReturn = "Date/Time" ' 8 Case dbBinary: strReturn = "Binary" ' 9 (no interface) Case dbText '10 If (objRecordset.Fields.Item(i).Attributes And dbFixedField) = 0& Then strReturn = "Text" Else strReturn = "Text (fixed width)" '(no interface) End If Case dbLongBinary: strReturn = "OLE Object" '11 Case dbMemo '12 If (objRecordset.Fields.Item(i).Attributes And dbHyperlinkField) = 0& Then strReturn = "Memo" Else strReturn = "Hyperlink" End If Case dbGUID: strReturn = "GUID" '15 'Attached tables only: cannot create these in JET. Case dbBigInt: strReturn = "Big Integer" '16 Case dbVarBinary: strReturn = "VarBinary" '17 Case dbChar: strReturn = "Char" '18 Case dbNumeric: strReturn = "Numeric" '19 Case dbDecimal: strReturn = "Decimal" '20 Case dbFloat: strReturn = "Float" '21 Case dbTime: strReturn = "Time" '22 Case dbTimeStamp: strReturn = "Time Stamp" '23 'Constants for complex types don't work prior to Access 2007 and later. Case 101&: strReturn = "Attachment" 'dbAttachment Case 102&: strReturn = "Complex Byte" 'dbComplexByte Case 103&: strReturn = "Complex Integer" 'dbComplexInteger Case 104&: strReturn = "Complex Long" 'dbComplexLong Case 105&: strReturn = "Complex Single" 'dbComplexSingle Case 106&: strReturn = "Complex Double" 'dbComplexDouble Case 107&: strReturn = "Complex GUID" 'dbComplexGUID Case 108&: strReturn = "Complex Decimal" 'dbComplexDecimal Case 109&: strReturn = "Complex Text" 'dbComplexText Case Else: strReturn = "unknown" End Select End If Next i FieldTypeName = strReturn End Function يتم استدعاء الوظيقة بشكل عام من خلال الكود الاتى Call CheckInputExist("FieldName", "TableName", Me.txtBox) وأخيرا المرفق للتجربة ملاحظة : تم تعديل المرفق والكود بناء على رد استاذى الجليل الباش مهندس @Moosak التعديل النهائى بتحديث المرفق بتاريخ يوم السبت 22 رمضان 1443 هـ , 23 -أبريل -2022 م تم إضافة وظيقة للتعرف نوع البيانات المستخدم فى الحقل داخل الجدول Check Input Exist.accdb
  13. السلام عليكم ورحمة الله تعالى وبركاته إصلاح مشاكل قواعد البيانات أداة لاستعادة البيانات الناجمة عن تلف قواعد البيانات تستخدم تقنيات متقدمة لفحص قواعد بيانات Microsoft Access التالفة وتدعم النسيقات (.mdb . accdb) وتقوم باستعادة أكبر قدر ممكن من البيانات مما يقلل الخسارة الناجمة عن تلف قواعد البيانات. الاداة مجانية للاستخدام الغير تجارى من يريد الكراك يراسلنى على الخاص حتى لا ننتهك قوانين المنتدى بنشرها 159905355_DataNumenAccessRepair.rar
  14. السلام عليكم ورحمة الله تعالى وبركاته تحية طيبة عطرة موديول واحد قمت بتجميع الدوال الهامة للتاريخ بحيث يسهل استخدامها مع الاخذ فى الاعتبار بمرونة التحكم الشامل فى كل كبيرة وصغيره بسم الله الرحمن الرحيم وعلى بركة الله طالما سوف نتطرق الى التاريخ والتعامل معه لابد أن نبدأ على خطى استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @jjafferr واقتبس من استاذى الجليل تلك الكلمات التى لابد ان تعلق فى اذهان كل من يتعامل مع دوال والتاريخ الروتين رقم 1 DateFormat Function DateFormat(ByVal varDate As Variant) As String 'Purpose: Return a delimited string in the date format used natively by JET SQL. 'Argument: A date/time value. 'Note: Returns just the date format if the argument has no time component, ' or a date/time format if it does. 'Author: Allen Browne. allen@allenbrowne.com, June 2006. ' 'calling the Function: DateFormat(The_Date_Field) 'a = dlookup("[some field]","some table","[id]=" & me.id & " And [Date_Field]=" & DateFormat(The_Date_Field)) ' If IsDate(varDate) Then If DateValue(varDate) = varDate Then DateFormat = Format$(varDate, "\#mm\/dd\/yyyy\#") Else DateFormat = Format$(varDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#") End If End If End Function الروتين رقم 2 ToWhat يقوم بعمل التحويل من التاريخ الميلادى الى الهجرى والعكس ولكن لابد من عمل جدول باسم tblAdjustHjriDate يحتوى على حقل رقمى باسم AdjustDay وذلك لوضع الفرق بالايام بين التاريخين حسب كل شهر للحصول على النتيجة الصحيحة ' ______ ______ .__ __. ____ ____ _______ .______ .___________. __ .__ __. _______ ' / | / __ \ | \ | | \ \ / / | ____|| _ \ | || | | \ | | / _____| ' | ,----'| | | | | \| | \ \/ / | |__ | |_) | `---| |----`| | | \| | | | __ ' | | | | | | | . ` | \ / | __| | / | | | | | . ` | | | |_ | ' | `----.| `--' | | |\ | \ / | |____ | |\ \----. | | | | | |\ | | |__| | ' \______| \______/ |__| \__| \__/ |_______|| _| `._____| |__| |__| |__| \__| \______| ' _______ ___ .___________. _______ _______ .______ ______ .___ ___. ' | \ / \ | || ____| | ____|| _ \ / __ \ | \/ | ' | .--. | / ^ \ `---| |----`| |__ | |__ | |_) | | | | | | \ / | ' | | | | / /_\ \ | | | __| | __| | / | | | | | |\/| | ' | '--' | / _____ \ | | | |____ | | | |\ \----.| `--' | | | | | ' |_______/ /__/ \__\ |__| |_______| |__| | _| `._____| \______/ |__| |__| ' _______ .______ _______ _______ ______ .______ __ ___ .__ __. .___________. ______ ' / _____|| _ \ | ____| / _____| / __ \ | _ \ | | / \ | \ | | | | / __ \ ' | | __ | |_) | | |__ | | __ | | | | | |_) | | | / ^ \ | \| | `---| |----`| | | | ' | | |_ | | / | __| | | |_ | | | | | | / | | / /_\ \ | . ` | | | | | | | ' | |__| | | |\ \----.| |____ | |__| | | `--' | | |\ \----.| | / _____ \ | |\ | | | | `--' | ' \______| | _| `._____||_______| \______| \______/ | _| `._____||__| /__/ \__\ |__| \__| |__| \______/ ' __ __ __ __ .______ __ ' | | | | | | | | | _ \ | | ' | |__| | | | | | | |_) | | | ' | __ | | | .--. | | | / | | ' | | | | | | | `--' | | |\ \----.| | ' |__| |__| |__| \______/ | _| `._____||__| ' ______ .______ .______ ___ ______ __ ___ ' / __ \ | _ \ | _ \ / \ / || |/ / ' | | | | | |_) | | |_) | / ^ \ | ,----'| ' / ' | | | | | / | _ < / /_\ \ | | | < ' | `--' | | |\ \----. | |_) | / _____ \ | `----.| . \ ' \______/ | _| `._____| |______/ /__/ \__\ \______||__|\__\ ' Public Function ToWhat(ByRef myData As String, To_Hijri_Milady As String) As String Dim CorctAdjustDay As Integer Dim SavedCal As Integer Dim strD As Date Dim strS As String On Error GoTo ErrorHandler 'to call the Function 'Hijri to Milady 'txt Milady date = ToWhat(txt Hijri date, "H") 'Milady to Hijri 'txt Hijri date = ToWhat(txt Milady date, "M") CorctAdjustDay = DLookup("[AdjustDay]", "tblAdjustHjriDate") If To_Hijri_Milady = "M" Then myData = Trim(Format(DateAdd("d", -1 * CorctAdjustDay, myData), "dd/mm/yyyy")) SavedCal = Calendar VBA.Calendar = 1 strD = CDate(myData) VBA.Calendar = 0 Else myData = Trim(Format(DateAdd("d", CorctAdjustDay, myData), "dd/mm/yyyy")) SavedCal = Calendar VBA.Calendar = 0 strD = CDate(myData) VBA.Calendar = 1 End If strS = CStr(strD) ToWhat = Format(strS, "dd/mm/yyyy") VBA.Calendar = SavedCal ErrorHandlerExit: Exit Function ErrorHandler: If Err = 13 Then MsgBox "Wrong Data", vbOKOnly + vbMsgBoxRight + vbMsgBoxRtlReading, "Wrong" Exit Function 'Resume Next Else Resume ErrorHandlerExit End If End Function الروتين رقم 3 MyNo للتحكم فى شكل ظهور الارقام بالعربية او بالهندية من خلال استخدام اليونيكود ' __ ___ .__ __. _______ __ __ ___ _______ _______ ______ _______ .__ __. __ __ .___ ___. .______ _______ .______ _______. ' | | / \ | \ | | / _____|| | | | / \ / _____|| ____| / __ \ | ____| | \ | | | | | | | \/ | | _ \ | ____|| _ \ / | ' | | / ^ \ | \| | | | __ | | | | / ^ \ | | __ | |__ | | | | | |__ | \| | | | | | | \ / | | |_) | | |__ | |_) | | (----` ' | | / /_\ \ | . ` | | | |_ | | | | | / /_\ \ | | |_ | | __| | | | | | __| | . ` | | | | | | |\/| | | _ < | __| | / \ \ ' | `----. / _____ \ | |\ | | |__| | | `--' | / _____ \ | |__| | | |____ | `--' | | | | |\ | | `--' | | | | | | |_) | | |____ | |\ \----..----) | ' |_______|/__/ \__\ |__| \__| \______| \______/ /__/ \__\ \______| |_______| \______/ |__| |__| \__| \______/ |__| |__| |______/ |_______|| _| `._____||_______/ ' Public Function MyNo(ByVal strNo As String, ByVal strLng As String) 'to call the Function 'To Arabic 'txtNoToAR=MyNo(txtNo,"Ar") 'To English 'txtNoTOEng=MyNo(txtNo,"En") If strLng = "Ar" Then strNo = Replace(strNo, ChrW(48), ChrW(1632)) strNo = Replace(strNo, ChrW(49), ChrW(1633)) strNo = Replace(strNo, ChrW(50), ChrW(1634)) strNo = Replace(strNo, ChrW(51), ChrW(1635)) strNo = Replace(strNo, ChrW(52), ChrW(1636)) strNo = Replace(strNo, ChrW(53), ChrW(1637)) strNo = Replace(strNo, ChrW(54), ChrW(1638)) strNo = Replace(strNo, ChrW(55), ChrW(1639)) strNo = Replace(strNo, ChrW(56), ChrW(1640)) strNo = Replace(strNo, ChrW(57), ChrW(1641)) MyNo = strNo ElseIf strLng = "En" Then strNo = Replace(strNo, ChrW(1632), ChrW(48)) strNo = Replace(strNo, ChrW(1633), ChrW(49)) strNo = Replace(strNo, ChrW(1634), ChrW(50)) strNo = Replace(strNo, ChrW(1635), ChrW(51)) strNo = Replace(strNo, ChrW(1636), ChrW(52)) strNo = Replace(strNo, ChrW(1637), ChrW(53)) strNo = Replace(strNo, ChrW(1638), ChrW(54)) strNo = Replace(strNo, ChrW(1639), ChrW(55)) strNo = Replace(strNo, ChrW(1640), ChrW(56)) strNo = Replace(strNo, ChrW(1641), ChrW(57)) MyNo = strNo End If End Function الروتين رقم 4 MnthName اسماء الشهور الهجرى - العربى( الميلادى) - الانجليزيى( الميلادى) - اختصارالانجليزيى( الميلادى) - القبطى - السريانى ' .__ __. ___ .___ ___. _______ _______. ______ _______ .___________. __ __ _______ .___ ___. ______ .__ __. .___________. __ __ _______. ' | \ | | / \ | \/ | | ____| / | / __ \ | ____| | || | | | | ____| | \/ | / __ \ | \ | | | || | | | / | ' | \| | / ^ \ | \ / | | |__ | (----` | | | | | |__ `---| |----`| |__| | | |__ | \ / | | | | | | \| | `---| |----`| |__| | | (----` ' | . ` | / /_\ \ | |\/| | | __| \ \ | | | | | __| | | | __ | | __| | |\/| | | | | | | . ` | | | | __ | \ \ ' | |\ | / _____ \ | | | | | |____ .----) | | `--' | | | | | | | | | | |____ | | | | | `--' | | |\ | | | | | | | .----) | ' |__| \__| /__/ \__\ |__| |__| |_______||_______/ \______/ |__| |__| |__| |__| |_______| |__| |__| \______/ |__| \__| |__| |__| |__| |_______/ ' Public Function MnthName(ByVal dtAnyDate As Date, ByVal strLng As String) 'to call the Function 'To Hijri 'txtMonthNameHijri =MnthName(txtDate,"HJ") 'To Arabic 'txtMonthNameArabic =MnthName(txtDate,"Ar") 'To English 'txtMonthNameEnglish =MnthName(txtDate,"En") 'To English Short 'txtMonthNameEnglish =MnthName(txtDate,"EnShrt") 'To Coptic 'txtMonthNameCoptic =MnthName(txtDate,"Cpti") 'To Syriac 'txtMonthNameSyriac =MnthName(txtDate,"Syr") Dim str01 As String Dim str02 As String Dim str03 As String Dim str04 As String Dim str05 As String Dim str06 As String Dim str07 As String Dim Str08 As String Dim Str09 As String Dim Str10 As String Dim Str11 As String Dim Str12 As String If strLng = "HJ" Then str01 = ChrW("1605") & ChrW("1581") & ChrW("1585") & ChrW("1605") str02 = ChrW("1589") & ChrW("1601") & ChrW("1585") str03 = ChrW("1585") & ChrW("1576") & ChrW("1610") & ChrW("1593") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1571") & ChrW("1608") & ChrW("1604") str04 = ChrW("1585") & ChrW("1576") & ChrW("1610") & ChrW("1593") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1570") & ChrW("1582") & ChrW("1585") str05 = ChrW("1580") & ChrW("1605") & ChrW("1575") & ChrW("1583") & ChrW("1610") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1571") & ChrW("1608") & ChrW("1604") & ChrW("1610") str06 = ChrW("1580") & ChrW("1605") & ChrW("1575") & ChrW("1583") & ChrW("1610") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1570") & ChrW("1582") & ChrW("1585") & ChrW("1577") str07 = ChrW("1585") & ChrW("1580") & ChrW("1576") Str08 = ChrW("1588") & ChrW("1593") & ChrW("1576") & ChrW("1575") & ChrW("1606") Str09 = ChrW("1585") & ChrW("1605") & ChrW("1590") & ChrW("1575") & ChrW("1606") Str10 = ChrW("1588") & ChrW("1608") & ChrW("1575") & ChrW("1604") Str11 = ChrW("1584") & ChrW("1608") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1602") & ChrW("1593") & ChrW("1583") & ChrW("1577") Str12 = ChrW("1584") & ChrW("1608") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1581") & ChrW("1580") & ChrW("1577") ElseIf strLng = "Ar" Then str01 = ChrW("1610") & ChrW("1606") & ChrW("1575") & ChrW("1610") & ChrW("1585") str02 = ChrW("1601") & ChrW("1576") & ChrW("1585") & ChrW("1575") & ChrW("1610") & ChrW("1585") str03 = ChrW("1605") & ChrW("1575") & ChrW("1585") & ChrW("1587") str04 = ChrW("1571") & ChrW("1576") & ChrW("1585") & ChrW("1610") & ChrW("1604") str05 = ChrW("1605") & ChrW("1575") & ChrW("1610") & ChrW("1608") str06 = ChrW("1610") & ChrW("1608") & ChrW("1606") & ChrW("1610") & ChrW("1577") str07 = ChrW("1610") & ChrW("1608") & ChrW("1604") & ChrW("1610") & ChrW("1577") Str08 = ChrW("1571") & ChrW("1594") & ChrW("1587") & ChrW("1591") & ChrW("1587") Str09 = ChrW("1587") & ChrW("1576") & ChrW("1578") & ChrW("1605") & ChrW("1576") & ChrW("1585") Str10 = ChrW("1575") & ChrW("1603") & ChrW("1578") & ChrW("1608") & ChrW("1576") & ChrW("1585") Str11 = ChrW("1606") & ChrW("1608") & ChrW("1601") & ChrW("1605") & ChrW("1576") & ChrW("1585") Str12 = ChrW("1583") & ChrW("1610") & ChrW("1587") & ChrW("1605") & ChrW("1576") & ChrW("1585") ElseIf strLng = "En" Then str01 = "January" str02 = "February" str03 = "March" str04 = "April" str05 = "May" str06 = "June" str07 = "July" Str08 = "August" Str09 = "September" Str10 = "October" Str11 = "November" Str12 = "December" ElseIf strLng = "EnShrt" Then str01 = "Jan" str02 = "Feb" str03 = "Mar" str04 = "Apr" str05 = "May" str06 = "Jun" str07 = "Jul" Str08 = "Aug" Str09 = "Sep" Str10 = "Oct" Str11 = "Nov" Str12 = "Dec" ElseIf strLng = "Cpti" Then str01 = ChrW("1591") & ChrW("1608") & ChrW("1576") & ChrW("1577") str02 = ChrW("1571") & ChrW("1605") & ChrW("1588") & ChrW("1610") & ChrW("1585") str03 = ChrW("1576") & ChrW("1585") & ChrW("1605") & ChrW("1607") & ChrW("1575") & ChrW("1578") str04 = ChrW("1576") & ChrW("1585") & ChrW("1605") & ChrW("1608") & ChrW("1583") & ChrW("1577") str05 = ChrW("1576") & ChrW("1588") & ChrW("1606") & ChrW("1587") str06 = ChrW("1576") & ChrW("1572") & ChrW("1608") & ChrW("1606") & ChrW("1577") str07 = ChrW("1571") & ChrW("1576") & ChrW("1610") & ChrW("1576") Str08 = ChrW("1605") & ChrW("1587") & ChrW("1585") & ChrW("1609") Str09 = ChrW("1578") & ChrW("1608") & ChrW("1578") Str10 = ChrW("1576") & ChrW("1575") & ChrW("1576") & ChrW("1577") Str11 = ChrW("1607") & ChrW("1575") & ChrW("1578") & ChrW("1608") & ChrW("1585") Str12 = ChrW("1603") & ChrW("1610") & ChrW("1575") & ChrW("1607") & ChrW("1603") ElseIf strLng = "Syr" Then str01 = ChrW("1603") & ChrW("1575") & ChrW("1606") & ChrW("1608") & ChrW("1606") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1579") & ChrW("1575") & ChrW("1606") & ChrW("1610") str02 = ChrW("1588") & ChrW("1576") & ChrW("1575") & ChrW("1591") str03 = ChrW("1570") & ChrW("1584") & ChrW("1575") & ChrW("1585") str04 = ChrW("1606") & ChrW("1610") & ChrW("1587") & ChrW("1575") & ChrW("1606") str05 = ChrW("1571") & ChrW("1610") & ChrW("1575") & ChrW("1585") str06 = ChrW("1581") & ChrW("1586") & ChrW("1610") & ChrW("1585") & ChrW("1575") & ChrW("1606") str07 = ChrW("1578") & ChrW("1605") & ChrW("1608") & ChrW("1586") Str08 = ChrW("1570") & ChrW("1576") Str09 = ChrW("1571") & ChrW("1610") & ChrW("1604") & ChrW("1608") & ChrW("1604") Str10 = ChrW("1578") & ChrW("1588") & ChrW("1585") & ChrW("1610") & ChrW("1606") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1571") & ChrW("1608") & ChrW("1604") Str11 = ChrW("1578") & ChrW("1588") & ChrW("1585") & ChrW("1610") & ChrW("1606") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1579") & ChrW("1575") & ChrW("1606") & ChrW("1610") Str12 = ChrW("1603") & ChrW("1575") & ChrW("1606") & ChrW("1608") & ChrW("1606") & ChrW("32") & ChrW("1575") & ChrW("1604") & ChrW("1571") & ChrW("1608") & ChrW("1604") End If MnthName = Choose(Format(dtAnyDate, "MM"), str01, str02, str03, str04, str05, str06, str07, Str08, Str09, Str10, Str11, Str12) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 5 DayName اسماء الايام - العربى - الانجليزى- اختصار الانجليزى ' .__ __. ___ .___ ___. _______ _______. ______ _______ _______ ___ ____ ____ _______. ' | \ | | / \ | \/ | | ____| / | / __ \ | ____| | \ / \ \ \ / / / | ' | \| | / ^ \ | \ / | | |__ | (----` | | | | | |__ | .--. | / ^ \ \ \/ / | (----` ' | . ` | / /_\ \ | |\/| | | __| \ \ | | | | | __| | | | | / /_\ \ \_ _/ \ \ ' | |\ | / _____ \ | | | | | |____ .----) | | `--' | | | | '--' | / _____ \ | | .----) | ' |__| \__| /__/ \__\ |__| |__| |_______||_______/ \______/ |__| |_______/ /__/ \__\ |__| |_______/ ' Public Function DayName(ByVal dtAnyDate As Date, ByVal strLng As String) 'to call the Function 'To Arabic Day Name 'txtDayNameAR =DayName(txtDate,"Ar") 'To English Day Name 'txtDayNameAR =DayName(txtDate,"En") 'To English Short Day Name 'txtDayNameEnòShrt =DayName(txtDate,"EnShrt") Dim strSat As String Dim strSun As String Dim strMon As String Dim strTues As String Dim strWed As String Dim strThurs As String Dim strFri As String If strLng = "Ar" Then strSat = ChrW("1575") & ChrW("1604") & ChrW("1587") & ChrW("1576") & ChrW("1578") strSun = ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1581") & ChrW("1583") strMon = ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1579") & ChrW("1606") & ChrW("1610") & ChrW("1606") strTues = ChrW("1575") & ChrW("1604") & ChrW("1579") & ChrW("1604") & ChrW("1575") & ChrW("1579") & ChrW("1575") & ChrW("1569") strWed = ChrW("1575") & ChrW("1604") & ChrW("1575") & ChrW("1585") & ChrW("1576") & ChrW("1593") & ChrW("1575") & ChrW("1569") strThurs = ChrW("1575") & ChrW("1604") & ChrW("1582") & ChrW("1605") & ChrW("1610") & ChrW("1587") strFri = ChrW("1575") & ChrW("1604") & ChrW("1580") & ChrW("1605") & ChrW("1593") & ChrW("1577") ElseIf strLng = "En" Then strSat = "Saturday" strSun = "Sunday" strMon = "Monday" strTues = "Tuesday" strWed = "Wednesday" strThurs = "Thursday" strFri = "Friday" ElseIf strLng = "EnShrt" Then strSat = "Sat" strSun = "Sun" strMon = "Mon" strTues = "Tue" strWed = "Wed" strThurs = "Thurs" strFri = "Fri" End If DayName = Choose(Weekday(dtAnyDate), strSun, strMon, strTues, strWed, strThurs, strFri, strSat) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 6 عدد ايام الشهر ' .__ __. __ __ .___ ___. .______ _______ .______ ______ _______ _______ ___ ____ ____ _______. ' | \ | | | | | | | \/ | | _ \ | ____|| _ \ / __ \ | ____| | \ / \ \ \ / / / | ' | \| | | | | | | \ / | | |_) | | |__ | |_) | | | | | | |__ | .--. | / ^ \ \ \/ / | (----` ' | . ` | | | | | | |\/| | | _ < | __| | / | | | | | __| | | | | / /_\ \ \_ _/ \ \ ' | |\ | | `--' | | | | | | |_) | | |____ | |\ \----. | `--' | | | | '--' | / _____ \ | | .----) | ' |__| \__| \______/ |__| |__| |______/ |_______|| _| `._____| \______/ |__| |_______/ /__/ \__\ |__| |_______/ ' ______ _______ _______. _______ __ _______ ______ .___________. _______ _______ .___ ___. ______ .__ __. .___________. __ __ ' / __ \ | ____| / || ____|| | | ____| / || || ____|| \ | \/ | / __ \ | \ | | | || | | | ' | | | | | |__ | (----`| |__ | | | |__ | ,----'`---| |----`| |__ | .--. | | \ / | | | | | | \| | `---| |----`| |__| | ' | | | | | __| \ \ | __| | | | __| | | | | | __| | | | | | |\/| | | | | | | . ` | | | | __ | ' | `--' | | | .----) | | |____ | `----.| |____ | `----. | | | |____ | '--' | | | | | | `--' | | |\ | | | | | | | ' \______/ |__| |_______/ |_______||_______||_______| \______| |__| |_______||_______/ |__| |__| \______/ |__| \__| |__| |__| |__| ' Public Function NumofDays(ByVal dtAnyDate As Date) NumofDays = Day(DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0)) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 7 تاريخ آخر يوم فى الشهر ' _______ ___ .___________. _______ ______ _______ __ ___ _______..___________. _______ ___ ____ ____ ' | \ / \ | || ____| / __ \ | ____| | | / \ / || | | \ / \ \ \ / / ' | .--. | / ^ \ `---| |----`| |__ | | | | | |__ | | / ^ \ | (----``---| |----` | .--. | / ^ \ \ \/ / ' | | | | / /_\ \ | | | __| | | | | | __| | | / /_\ \ \ \ | | | | | | / /_\ \ \_ _/ ' | '--' | / _____ \ | | | |____ | `--' | | | | `----. / _____ \ .----) | | | | '--' | / _____ \ | | ' |_______/ /__/ \__\ |__| |_______| \______/ |__| |_______|/__/ \__\ |_______/ |__| |_______/ /__/ \__\ |__| ' ______ _______ _______. _______ __ _______ ______ .___________. _______ _______ .___ ___. ______ .__ __. .___________. __ __ ' / __ \ | ____| / || ____|| | | ____| / || || ____|| \ | \/ | / __ \ | \ | | | || | | | ' | | | | | |__ | (----`| |__ | | | |__ | ,----'`---| |----`| |__ | .--. | | \ / | | | | | | \| | `---| |----`| |__| | ' | | | | | __| \ \ | __| | | | __| | | | | | __| | | | | | |\/| | | | | | | . ` | | | | __ | ' | `--' | | | .----) | | |____ | `----.| |____ | `----. | | | |____ | '--' | | | | | | `--' | | |\ | | | | | | | ' \______/ |__| |_______/ |_______||_______||_______| \______| |__| |_______||_______/ |__| |__| \______/ |__| \__| |__| |__| |__| ' Public Function LastDayInMonth(ByVal dtAnyDate As Date) As Date 'to call the Function 'txtLastDayInMonth =LastDayInMonth(txtDate) LastDayInMonth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 8 تاريخ اول يوم فى الشهر Public Function FstDayOfMth(ByVal dtAnyDate As Date) As Date On Error GoTo handleError FstDayOfMth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 1) GoTo handleSuccess Exit Function handleSuccess: GoTo cleanUp Exit Function handleError: If Err.Number = 94 Then 'createFolder = True Else MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description End If GoTo cleanUp cleanUp: Exit Function End Function الروتين رقم 9 تاريخ اول يوم فى الشهر التالى Public Function FstDayOfNextMnth(ByVal dtAnyDate As Date) As Date FstDayOfNextMnth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 10 تاريخ اول يوم فى الشهر السابق Public Function FstDayPrevMnth(ByVal dtAnyDate As Date) As Date FstDayPrevMnth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) - 1, 1) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 11 تاريخ آخر يوم فى الشهر Public Function LstDayMnth(ByVal dtAnyDate As Date) As Date LstDayMnth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 1, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 12 تاريخ آخر يوم فى الشهر التالى Public Function LstDayNextMnth(ByVal dtAnyDate As Date) As Date LstDayNextMnth = DateSerial(Year(dtAnyDate), Month(dtAnyDate) + 2, 0) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 13 تاريخ آخر يوم فى الشهر السابق Public Function LstDayPrevMnth(ByVal dtAnyDate As Date) As Date LstDayPrevMnth = DateSerial(Year(dtAnyDate), Month(dtAnyDate), 0) End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 14 ظهور لغة الوقت التى تريدها - عربى - انجلبزى Public Function TimeByLng(ByVal dtAnyDate As Variant, ByVal strLng As String) Dim strAM As String: strAM = ChrW("1589") & ChrW("1576") & ChrW("1575") & ChrW("1581") & ChrW("1575") & ChrW("1611") Dim strPM As String: strPM = ChrW("1605") & ChrW("1587") & ChrW("1575") & ChrW("1569") & ChrW("1611") If strLng = "Ar" Then TimeByLng = MyNo(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), "AM", strAM), "PM", strPM), "ar") ElseIf strLng = "En" Then TimeByLng = MyNo(Replace(Replace(Format(dtAnyDate, "hh:nn:ss AM/PM"), strAM, "AM"), strPM, "PM"), "En") End If End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 15 ظهور لغة الوقت التى تريدها - عربى - انجلبزى Public Function TimeLng(ByVal strLng As String) Dim strAM As String: strAM = ChrW("1589") & ChrW("1576") & ChrW("1575") & ChrW("1581") & ChrW("1575") & ChrW("1611") Dim strPM As String: strPM = ChrW("1605") & ChrW("1587") & ChrW("1575") & ChrW("1569") & ChrW("1611") If strLng = "Ar" Then TimeLng = MyNo(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), "AM", strAM), "PM", strPM), "ar") ElseIf strLng = "En" Then TimeLng = MyNo(Replace(Replace(Format(Now(), "hh:nn:ss AM/PM"), strAM, "AM"), strPM, "PM"), "En") End If End Function '----------------------------End------------------------------------------------------------------------------------------- الروتين رقم 16 ظهور لغة التاريخ التى تريدها - عربى - انجلبزى Public Function DateByLng(ByVal dtAnyDate As Variant, ByVal strLng As String) If strLng = "Ar" Then DateByLng = MyNo(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & ChrW(1605), "ar") ElseIf strLng = "En" Then DateByLng = MyNo(Format(dtAnyDate, "dd\/mm\/yyyy") & Space(2) & ChrW(1605), "En") End If End Function '----------------------------End------------------------------------------------------------------------------------------- يتبع .... DateFunctions.zip
  15. السلام عليكم ورحمة الله تعالى وبركاته قائمة ديناميكية طى وتوسيع لهواة تصميم واجهات مودرن اترككم مع التجربــة collapse menu.zip
  16. Version 4.0.3 بدعم مكتبات جافا

    385 تنزيل

    تم التعديل ليتناسب مع نسخ الاوفيس بدأ من 2007 وحتى 2021 للنوتان 32 , 64 التطبيق اهداء الى منتدانا الحبيب ورواد المنتدى العمل حتى يخرج بهذه الصورة يعلم الله وحده الجهد المبذول به اسال الله تعالى ان يتقبل هذا العمل صدقة جارية الى ما شاء الله تعالى ms access becomes an authorized e-invoicing solution provider in Saudi Arabia by www.officena.net Start your e-invoicing journey حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية يتم قراءة الرمز الناتج ان شاء الله عبر القارىء الرسمي الخاص بالهيئة ( تطبيق جوال ) حمل من هنا : التطبيق الرسمي لهيئة الزكاة والضريبة والجمارك يتم قراءة الرمز الناتج ان شاء الله عبر قارىء خاص ( تطبيق جوال ) حمل من هنا : تطبيق قرائة رمز الاستجابة طبقات لمتطلبات هيئة الزكاة والضريبة والجمارك متطلبات التشغيل : Framework الاصدار 4 ------------------------------------------------------------------------------- يمكن تحميل الملف الاتى هو يقوم بالتحديثات اللازمة سواء ويندوز 7 , 10 , 11 إذهب الى موقع التحميل : من هنا ( تحميل مباشر من mediafire .. من رفعي انا على حسابي الشخصي بالموقع ) ميزات برنامج All in one Runtimes: سهل الاستخدام و مفيد للغاية في تقليل الزمن الضروري للبحث عن الأدوات كلٍ على حدا. مجاني بشكل كامل و يقدم الكثير من الفائدة و يمكنه حمايتك من المواقع التي قد تصيب جهازك بفيروسات سيئة عند التحميل منها. يعمل بشكل ذكي حيث يقوم بتحديد ما يحتاجه حاسبك و لن يقوم بتثبيت كل الأدوات بشكل عشوائي. يقدم مجموعة كبيرة من الأدوات الضرورية في حاسبك و أهمها: .NET Framework 4.6 + Updates Java Runtime Environment 8 DirectX 9.0c Extra files General runtime files Microsoft Visual C++ Runtimes (v2005 – v2015) Microsoft Visual J# 2.0 SE Microsoft Silverlight 5 Shockwave Player 12 (Internet Explorer Plugin) ------------------------------------------------------------------------------- الجديد فى هذا الموضوع وسبب تطوير تلك القاعدة . نظرا للمشاكل التي واجهت أحبابي سابقا بسبب تسجيل الملفات .. تم بفضل الله تعالى حل كل المشاكل تقريبا لن نحتاج الى نقل مجلد ملفات مكتبات الـ DLL الى أي مكان يتم إنشاء المجلد اليا بنفس مسار القاعدة يتم تحميل الملفات من قاعدة البيانات اليا تشغيل ملف التسجيل Register.bat اليا.. عند فتح القاعدة للمرة الأولى ومحاولة انشاء رمز الـ Qr وفى حالة عدم تسجيل مكتبة الجافا يتم اغلاق القاعدة اليا وفتح ملف التسجيل كمسؤول نظام دون أي تدخل من المستخدم نهائيا مميزات القاعدة الحفاظ على الملفات الهامة بحملها داخل القاعدة وتحميلها لمسار القاعدة فى كل مرة يتم فيها فتح القاعدة شغيل ملف التسجيل Register.bat اليا عند الحاجة لذلك يدعم النواتان 64 , 32 تشفير البيانات طبقا لمتطلبات هيئة الزكاة والضريبة والجمارك السعودية الاحتفاظ بالبيانات المشفرة لكل سجل حجم الصورة الخاصة برمز الاستجابة السريع QR CODE صغير جدا لمن يريد الاحتفاظ بهم لكل سجل أتمنى لكم تجربة ممتعة ... الفائدة من تصميى المتواضع وافكارى والمميزات حمل ملفاتى الهامة داخل القاعدة وبذلك لن يتم فقدانها مطلقا لاى سبب الا بفقد القاعدة نفسها عند نقل القاعدة لاى جهاز يتم وضع الملفات بتحميلها من القاعدة الى الجهاز اليا فى مسار القاعدة فلن يشغل بال المستخدم اى شئ بخصوص ملفات المكتبات عند عدم تسجيل المكتبات يتم ذلك اليا دون ادنى تدخل من المستخدم يتم فتح الملف الدفعى اليا فى حالة عدم تسجيل المكتبات وهو يعيد تشغيل نفسه كمسؤل ويقوم باللازم عند الانتها للملف الدفعى من التسجيل للمكتبات يعيد فتح القاعدة اليا واغلاق نفسه وجب التنويه لبعض النقاط لمن يريد نقل الافكار الى عمله مراعاة والاخذ فى الاعتبار عند محاولة تغيير اسم القاعدة ان اردتم لابد من تغيره كذلك بنفس الاسم الجديد فى الملف الدفعى حيث انه يقوم بفتح القاعدة اليا بعد التسجيل مراعاة الاخذ فى الاعتبار عند محاولة تغيير اسم النموذج frmElcInvoicing تغير الاسم كذلك فى نموذج البدأ UsysfrmInsertAllObjects الحرص على وجود الجدول UsystblBlob و الموديول UsysmodBlob والنموذج UsysfrmInsertAllObjects لانهم المختصون بحمل ملفات المكتبات داخل القاعدة وتحميلها وتسجيلها بشكل آلى بالهناء لكم وبالتوفيق للحميع ان شاء الله
  17. السلام عليكم ورحمة الله وبركاته احيانا تحدث مشكلات عند تنفيذ احد الاجراءات تبعا للكود المستخدم فكرتى المتواضعة فى هذا المرفق 1- تسجيل الاخطاء ليقف المصمم , المطور , المبرمج على مكان الخطأ تحديدا ورقمه لسهولة حل المشكلة 2- تجاوز الاخطاء كما يترائى لـ المصمم , المطور , المبرمج من خلال الأخطاء التى تم تصيدها وتسجيلها بالجدول Write Error Log .mdb
  18. اعرض الملف ksa e-invoicing تم التعديل ليتناسب مع نسخ الاوفيس بدأ من 2007 وحتى 2021 للنوتان 32 , 64 التطبيق اهداء الى منتدانا الحبيب ورواد المنتدى ولكن اشهد الله تعالى ان هذا العمل مقدم لكل من يريده مجانا وعلى سبيل الهدية لوجه الله تعالى ولا اسمح نهائيا ببيعه اللهم انى بلغت اللهم فاشهد العمل حتى يخرج بهذه الصورة يعلم الله وحده الجهد المبذول به اسال الله تعالى ان يتقبل هذا العمل صدقة جارية الى ما شاء الله تعالى ms access becomes an authorized e-invoicing solution provider in Saudi Arabia by www.officena.net Start your e-invoicing journey حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية يتم قراءة الرمز الناتج ان شاء الله عبر القارىء الرسمي الخاص بالهيئة ( تطبيق جوال ) حمل من هنا : التطبيق الرسمي لهيئة الزكاة والضريبة والجمارك يتم قراءة الرمز الناتج ان شاء الله عبر قارىء خاص ( تطبيق جوال ) حمل من هنا : تطبيق قرائة رمز الاستجابة طبقات لمتطلبات هيئة الزكاة والضريبة والجمارك متطلبات التشغيل : Framework الاصدار 4 ------------------------------------------------------------------------------- يمكن تحميل الملف الاتى هو يقوم بالتحديثات اللازمة سواء ويندوز 7 , 10 , 11 إذهب الى موقع التحميل : من هنا ( تحميل مباشر من mediafire .. من رفعي انا على حسابي الشخصي بالموقع ) ميزات برنامج All in one Runtimes: سهل الاستخدام و مفيد للغاية في تقليل الزمن الضروري للبحث عن الأدوات كلٍ على حدا. مجاني بشكل كامل و يقدم الكثير من الفائدة و يمكنه حمايتك من المواقع التي قد تصيب جهازك بفيروسات سيئة عند التحميل منها. يعمل بشكل ذكي حيث يقوم بتحديد ما يحتاجه حاسبك و لن يقوم بتثبيت كل الأدوات بشكل عشوائي. يقدم مجموعة كبيرة من الأدوات الضرورية في حاسبك و أهمها: .NET Framework 4.6 + Updates Java Runtime Environment 8 DirectX 9.0c Extra files General runtime files Microsoft Visual C++ Runtimes (v2005 – v2015) Microsoft Visual J# 2.0 SE Microsoft Silverlight 5 Shockwave Player 12 (Internet Explorer Plugin) ------------------------------------------------------------------------------- الجديد فى هذا الموضوع وسبب تطوير تلك القاعدة . نظرا للمشاكل التي واجهت أحبابي سابقا بسبب تسجيل الملفات .. تم بفضل الله تعالى حل كل المشاكل تقريبا لن نحتاج الى نقل مجلد ملفات مكتبات الـ DLL الى أي مكان يتم إنشاء المجلد اليا بنفس مسار القاعدة يتم تحميل الملفات من قاعدة البيانات اليا تشغيل ملف التسجيل Register.bat اليا.. عند فتح القاعدة للمرة الأولى ومحاولة انشاء رمز الـ Qr وفى حالة عدم تسجيل مكتبة الجافا يتم اغلاق القاعدة اليا وفتح ملف التسجيل كمسؤول نظام دون أي تدخل من المستخدم نهائيا مميزات القاعدة الحفاظ على الملفات الهامة بحملها داخل القاعدة وتحميلها لمسار القاعدة فى كل مرة يتم فيها فتح القاعدة شغيل ملف التسجيل Register.bat اليا عند الحاجة لذلك يدعم النواتان 64 , 32 تشفير البيانات طبقا لمتطلبات هيئة الزكاة والضريبة والجمارك السعودية الاحتفاظ بالبيانات المشفرة لكل سجل حجم الصورة الخاصة برمز الاستجابة السريع QR CODE صغير جدا لمن يريد الاحتفاظ بهم لكل سجل أتمنى لكم تجربة ممتعة ... الفائدة من تصميى المتواضع وافكارى والمميزات حمل ملفاتى الهامة داخل القاعدة وبذلك لن يتم فقدانها مطلقا لاى سبب الا بفقد القاعدة نفسها عند نقل القاعدة لاى جهاز يتم وضع الملفات بتحميلها من القاعدة الى الجهاز اليا فى مسار القاعدة فلن يشغل بال المستخدم اى شئ بخصوص ملفات المكتبات عند عدم تسجيل المكتبات يتم ذلك اليا دون ادنى تدخل من المستخدم يتم فتح الملف الدفعى اليا فى حالة عدم تسجيل المكتبات وهو يعيد تشغيل نفسه كمسؤل ويقوم باللازم عند الانتها للملف الدفعى من التسجيل للمكتبات يعيد فتح القاعدة اليا واغلاق نفسه وجب التنويه لبعض النقاط لمن يريد نقل الافكار الى عمله مراعاة والاخذ فى الاعتبار عند محاولة تغيير اسم القاعدة ان اردتم لابد من تغيره كذلك بنفس الاسم الجديد فى الملف الدفعى حيث انه يقوم بفتح القاعدة اليا بعد التسجيل مراعاة الاخذ فى الاعتبار عند محاولة تغيير اسم النموذج frmElcInvoicing تغير الاسم كذلك فى نموذج البدأ UsysfrmInsertAllObjects الحرص على وجود الجدول UsystblBlob و الموديول UsysmodBlob والنموذج UsysfrmInsertAllObjects لانهم المختصون بحمل ملفات المكتبات داخل القاعدة وتحميلها وتسجيلها بشكل آلى بالهناء لكم وبالتوفيق للحميع ان شاء الله صاحب الملف ابو جودي تمت الاضافه 20 ديس, 2021 الاقسام قسم الأكسيس  
  19. السلام عليكم ورحمة الله تعالى وبركاته الجواب يعرف من العنوان واترككم مع التجربة ـــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــــ SmartSort.accdb
  20. فكرة جديدة لاحتساب تاريخ نهاية الصلاحية بدون بدون حتى كتابة تاريخ الصلاحية داخل الجدول ExpirationDate.mdb
  21. التلميح داخل مربع النص مع علامة مائية فى حالة كان مربع النص فارغ ويختفيان بمجرد التركيز داخل مربه النص او الكتابة ... ToolTip.mdb
  22. شفافيــــــــــــTransparent Formsــــــــــــة النماذج Transparent Forms.mdb
×
×
  • اضف...

Important Information