Moosak

وعليكم السلام ورحمة الله وبركاته أخي العنزي 🙂 تفضل هذه هي الطريقة : والنتيجة : Prog1.rar

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

ربما يفيدك قناع الإدخال في هذا الموضوع ..

وعليكم السلام ورحمة الله وبركاته 🙂 استخدم داله Dlast.. Nz(Dlast("[fieldName]";"[TableName]"))+1

وعليكم السلام ورحمة الله وبركاته 🙂 وهنا أيضا :

نعم تماما كما ذكرت مهندسنا العزيز .. وأضيف أني أرى من الأسهل استخدام خاصية الـ Tag بوضع علامة معينة عليه للعناصر المراد التحكم بها ( وذلك للخروج من متاهات أسماء العناصر وأنواعها ) 😅 نضع العلامة أو الرمز هنا : ثم نستخدمها في الكود هكذا : For Each ctl In Me.Controls If ctl.Tag = "*" Then ctl.BackColor = RGB(150, 180, 215) End If Next ctl طبعا الشرح للمبتدأين أمثالي .. أما لكم أنتم فمن باب " وذكّر ... " 😁

ذكرني هذا الموضوع بمنشور قديم تم استخدام نفس التقنية فيه 😊👌🏻 .. أعيد تذكيركم به .. مع إسبال الشكر الجزيل للأساتذة الأعزاء المهندسين قاسم وخالد .. نفعنا الله بهما .. وأمد في أعمارهما 🙂🌹

ما شاء الله فكر أمني وطريقة جيدة للاحتراز من العبث 🙂 وهل تقوم بتغيير الامتداد يدويا عند الاستعادة ؟

وعليكم السلام ورحمه الله وبركاته 🙂 تفضل هذا كود تصدير استعلام معين إلى ملف أكسل - نقلته كما هو بدون تعديل - وطريقة استخدامه مشروحة في الكود : '--------------------------------------------------------------------------------------- ' Procedure : Export2XLS ' Author : Daniel Pineault, CARDA Consultants Inc. ' Website : http://www.cardaconsultants.com ' Purpose : Export recordset to Excel ' Copyright : The following may be altered and reused as you wish so long as the ' copyright notice is left unchanged (including Author, Website and ' Copyright). It may not be sold/resold or reposted on other sites (links ' back to this site are allowed). ' ' Input Variables: ' ~~~~~~~~~~~~~~~~ ' sQuery : Name of the table, or SQL Statement to be used to export the records ' to Excel ' ' Usage: ' ~~~~~~ ' Export2XLS "qryCustomers" ' Call Export2XLS("qryCustomers") ' ' Revision History: ' Rev Date(yyyy/mm/dd) Description ' ************************************************************************************** ' 1 2012-Apr-18 Initial Release ' 2 2015-May-01 Header Clarifications '--------------------------------------------------------------------------------------- Function Export2XLS(ByVal sQuery As String) Dim oExcel As Object Dim oExcelWrkBk As Object Dim oExcelWrSht As Object Dim bExcelOpened As Boolean Dim db As DAO.Database Dim rs As DAO.Recordset Dim iCols As Integer Const xlCenter = -4108 'Start Excel On Error Resume Next Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one Err.Clear On Error GoTo Error_Handler Set oExcel = CreateObject("Excel.Application") bExcelOpened = False Else 'Excel was already running bExcelOpened = True End If On Error GoTo Error_Handler oExcel.ScreenUpdating = False oExcel.Visible = False 'Keep Excel hidden until we are done with our manipulation Set oExcelWrkBk = oExcel.Workbooks.Add() 'Start a new workbook Set oExcelWrSht = oExcelWrkBk.Sheets(1) 'Open our SQL Statement, Table, Query Set db = CurrentDb Set rs = db.OpenRecordset(sQuery, dbOpenSnapshot) With rs If .RecordCount <> 0 Then 'Build our Header For iCols = 0 To rs.Fields.Count - 1 oExcelWrSht.Cells(1, iCols + 1).Value = rs.Fields(iCols).Name Next With oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ oExcelWrSht.Cells(1, rs.Fields.Count)) .Font.Bold = True .Font.ColorIndex = 2 .Interior.ColorIndex = 1 .HorizontalAlignment = xlCenter End With 'Copy the data from our query into Excel oExcelWrSht.Range("A2").CopyFromRecordset rs oExcelWrSht.Range(oExcelWrSht.Cells(1, 1), _ oExcelWrSht.Cells(1, rs.Fields.Count)).Columns.AutoFit 'Resize our Columns based on the headings oExcelWrSht.Range("A1").Select 'Return to the top of the page Else MsgBox "There are no records returned by the specified queries/SQL statement.", vbCritical + vbOKOnly, "No data to generate an Excel spreadsheet with" GoTo Error_Handler_Exit End If End With ' oExcelWrkBk.Close True, sFileName 'Save and close the generated workbook ' 'Close excel if is wasn't originally running ' If bExcelOpened = False Then ' oExcel.Quit ' End If Error_Handler_Exit: On Error Resume Next oExcel.Visible = True 'Make excel visible to the user rs.Close Set rs = Nothing Set db = Nothing Set oExcelWrSht = Nothing Set oExcelWrkBk = Nothing oExcel.ScreenUpdating = True Set oExcel = Nothing Exit Function Error_Handler: MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _ "Error Number: " & Err.Number & vbCrLf & _ "Error Source: Export2XLS" & vbCrLf & _ "Error Description: " & Err.Description _ , vbOKOnly + vbCritical, "An Error has Occurred!" Resume Error_Handler_Exit End Function

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

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

بالنسبة لاسم الملف nam يمكنك اختصاره هكذا ، مع تصحيح امتداد اسم الملف : nam = "Acc_Tavuk_" & Format(Now,"dd-mm-yyyy_hh-nn-ss am/pm" & ".Accdb"

وعليك السلام ورحمة الله وبركاته أخي صابر 🙂 جرب الآن ... dlookup problem.rar

وعليك السلام ورحمة الله وبركاته أخي محمد 🙂 أضف هذين السطرين إلى أمر عند النقر للصور : Private Sub ãÑÝÞ1_Click() [Forms]![a3]![a2]![ss] = Me.ImageName ' أضف هذين السطرين [Forms]![a3]![a2]![ss].SetFocus Me.Visible = False End Sub

بالمناسبة أخي عبدالله جربت الكود الخاص بك واشتغل معي تمام .. ولكن مع بعض التعديلات والتي ربما هي سبب المشكلة عندك : أعتقد أن المشكلة في أحد هذين السطرين ، قد تكون المسارات غير موجودة لذلك لا يستطيع نسخ القاعدة لديك ..

وعليكم السلام ورحمة الله وبركاته أخي محمد 🙂 أنظر هنا :

وعليكم السلام ورحمة الله وبركاته أخي عبدالله 🙂 لو صورت الجزئية التي يقف عليها المؤشر بالأصفر عند الضغط على ال Debug وعلى العموم يمكنك ببساطة تغيير الكود .. هناك الكثير من الأكواد التي تؤدي نفس العمل .. 🙂 هذا الكود الذي أستخدمه أنا ويعمل معي جيد ، الكود يأخذ نسخة لقاعدة البيانات كلها إذا كانت غير مقسمة . وإذا كانت مقسمة فإنه ينسخ ملف الجداول فقط . وفي كلا الحالتين الكود ينشئ النسخة في مجلد اسمه Backup بجانب البرنامج : Public Sub Backupme() On Error GoTo MyErr Dim OldFile, NewFile, CopyMyDB, wheretoBackup, BackupFolder, DBName As String If IsNull(DLookup("Database", "MSysObjects", "Type=6")) Then OldFile = CurrentProject.FullName wheretoBackup = CurrentProject.Path Else OldFile = DLookup("Database", "MSysObjects", "Type=6") wheretoBackup = Left(OldFile, InStrRev(OldFile, "\")) End If BackupFolder = wheretoBackup & "\Backup" On Error Resume Next If Len(Dir(BackupFolder)) = 0 Then MkDir BackupFolder Else End If On Error GoTo MyErr DBName = Left(CurrentProject.Name, InStrRev(CurrentProject.Name, ".") - 1) NewFile = wheretoBackup & "\Backup\" & DBName & "-Backup-" & Format(Date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn-ss-AMPM.") & Right(OldFile, 5) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MsgBox "Backup……..Done" & vbNewLine & vbNewLine & "Saved in :" & vbNewLine & NewFile, , " " MyErr: If Err.Number <> 0 Then MsgBox Err.Number & " - " & Err.Description End If End Sub '=======================================(كود آخر) Public Function CreateBackup() As Boolean Dim Source As String Dim Target As String Dim a As Integer Dim objFSO As Object Dim Path As String Path = CurrentProject.Path 'get location of current folder Source = CurrentDb.Name Target = Path & "\BackupDB " Target = Target & Format(Now(), "mm-dd") & ".accdb" ' create the backup a = 0 Set objFSO = CreateObject("Scripting.FileSystemObject") a = objFSO.CopyFile(Source, Target, True) Set objFSO = Nothing End Function وهذا الكود للمهندس محمد عصام :

تفضل أخي .. استخدمت نفس الكود هنا :

وعليكم السلام ورحمة الله وبركاته .. 🙂 هذا كود API وظيفته نقل التركيز من نافذة الأكسس إلى برنامج آخر أو إعادة التركيز إلى نافذة الأكسس مجدد : #If VBA7 Then Public Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr #Else Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long #End If الدالة تحتاج إلى المعامل التالي hwnd للبرنامج الذي تريد التركيز عليه سواء كان الأكسس أو برنامج آخر ( بعدما تكون قد فتحته كـ Object ) .. وطريقة استدعائه كالتالي : SetForegroundWindow oWMP.hwnd 'windows media player SetForegroundWindow Application.hwnd 'Access

وعليكم السلام ورحمة الله وبركاته أخي عمر .. 🙂 أعتقد أن عليك كتابة هذه بالطريقة التالية : [Forms]![frmAddPatyCash]![SubfrmPatyCash].[Form]![txtInvDate] وذلك في حال الإشارة لعنصر موجود في النموذج الفرعي .. invDateCh = DLookup("[InvDate]", "[TblBPCash]", "[InvDate] =#" & [Forms]![frmAddPatyCash]![SubfrmPatyCash].[Form]![txtInvDate] & "# And [InvNo] ='" & [Forms]![frmAddPatyCash]![SubfrmPatyCash].[Form]![txtInvNo] & "' ")

الحل الأسهل أن تضيف إلى اسم الملف التاريخ والوقت لتتجنب تكرار الاسم 🙂 بحيث يكون اسم الملف هكذا مثلا : FileName = "c:\ReportsFolder\Report-" & Format(Now,"dd-mm-yyyy hh-nn-ss" & ".pdf"

هذا الملف يعمل لدي بشكل جيد .. 🙂

وهذه دالة أخرى في حال لم تعمل معك الطريقة السابقة الدالة توضع في موديول وتظيف المكتبة التالية :Microsoft Scripting Runtime Public Function DleteFolder(FolderPath As String) Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFolder FolderPath, True Set fs = Nothing End Function ثم تستخدمها بنفس الطريقة السابقة مع تعديم اسم الدالة : Dim txtPath as String txtPath = "D:\System\PDF\" & me.id DleteFolder txtPath

تفضل أخي العزيز : 🙂 Dim txtPath as String txtPath = "D:\System\PDF\" & me.id Kill txtPath

أهلا بك أخي @UserUser2 🙂 ضع هذه الدالة في موديول : Public Function IsFileExists(txtPath As String) As Boolean ' To check whether a given file or folder exists or not If Len(Dir(txtPath, vbDirectory)) = 0 Then IsFileExists = False Else IsFileExists = True End If End Function بعدها في النموذج أو مكان كتابة الكود للتحقق من وجود الملف أكتبها هكذا : Dim txtPath as String txtPath = "D:\System\PDF\" & me.id If IsFileExists(txtPath) = True Then 'الأمر الذي تريد فعله إذا كان المجلد موجود Else 'الأمر الذي تريد فعله إذا لم يكن المجلد موجود End IF