سامي الحداد

ماشاءالله عمل رائع وجميل بارك الله فيك اخي فادي

السلام عليكم اخي @Ahmos

عمل رائع سلمت يداك 

الف مبروك اخي العزيز @Ahmos انضمامك لفريق الخبراء تستأهل اكثر 

تحياتي لك 

الف الف مبروك أخي الفاضل فادي تستاهل وبجدارة اللقب على ما تقدمه دائما لهذا الصرح الكبير

تحياتي لك

السلام عليكم

مشاركة مع الاستاذ @Moosak تعديل بسيط على الكود

عسى ان يكون هو المطلوب

بالتوفيق

ta13.rar

7 دقائق مضت, Foksh said:

عذراً ، لم انتبه لمشاركة الأستاذ @سامي الحداد

الظاهر اننا كنا نكتب في نفس الوفت استادي الفاضل فادي تحياتي لك.

 وهذه مشاركتي بالنسبة لــــ  كود استعلام التحديث

UPDATE [ارقام مسلسله] SET مسلسل = Left([مسلسل], InStr([مسلسل], "/") - 1) & "/" & Year(Date());

ونصيحة نكررها داىما ابتعد عن المسميات باللغة العربية.

بالتوفيق

16 ساعات مضت, Abdelaziz Osman said:

ولكن التعبير المشار اليه بالصورة التالية جعل بعض الاكواد الاخرى لاتعمل بالشكل المطلوب

هذا بسبب المتغيرات غير المعلنة

المشكلة انه يتم استخدام المتغيرات دون الإعلان عنها باستخدام

Dim أو Public أو Private.

قم بتعريف كافة المتغيرات قبل استخدامها

تحقق من وجود متغيرات غير معلنة، وأخطاء مطبعية،

يمكنك استخدام Debug.Print لمعرفة اين الخطاء وايضا في محرر الاكواد استخدم  Debug → Compile 

واليك تعديل  بسيط للكود ولكن تأكد اولا من كل  المتغيرات في برنامجك.

Option Compare Database
Option Explicit

Private Sub Kind_AfterUpdate()
    Dim frm As Form
    If Not IsNull(Me.Kind) Then
       Set frm = Me.AGR.Form
       frm!Kind = Nz(Me.Kind, "")
       Set frm = Nothing
    End If
End Sub

بالتوفيق

السلام عليكم

مشاركة مع الاساتدة 

بدون استعلام 

11 ساعات مضت, Abdelaziz Osman said:

تمام سيدى الا يمكن يحدث التحديث بعد الضغط على زرار enter بالكيبورد

Private Sub Kind_AfterUpdate()
    Dim frm As Form
    If Not IsNull(Me.kind) Then
       
        Set frm = Me!AGR.Form
        frm!kind = Me.kind
    End If
End Sub

بالتوفيق

Subform (1).accdb

تفضل اخي الكريم حسب ما فهمت

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

Private Sub FilterMe_Click()
    Dim strWhere As String
    
strWhere = "[تاريخ التقرير] Between #" & Format(Me.date1, "mm/dd/yyyy") & "# And #" & Format(Me.date2, "mm/dd/yyyy") & "#"
DoCmd.OpenForm "Screen_Date", acViewNormal, , strWhere
End Sub

واليك الملف 

بالتوفيق

data.accdb

وعليكم السلام

تفضل أخي حسب ما فهمت

Private Sub TXT_AfterUpdate()
    Dim FormName As String
    Dim RecordID As String
    Dim FilterCondition As String

    FormName = Me.TXT.Value
    RecordID = Me!ID.Value

    If Not IsNull(FormName) And Not IsNull(RecordID) Then
        FilterCondition = "[ID] = " & RecordID

        DoCmd.OpenForm FormName, , , FilterCondition
    Else
        MsgBox " .الرجاء تحديد النموذج والسجل لفتحه ", vbExclamation
    End If
End Sub

واليك الملف

بالتوفيق

فتح نموذج محدد من خلال نموذج فرعي.accdb

في 16‏/5‏/2024 at 18:02, jo_2010 said:

المطلوب: اريد حذفها من الفولدر الخاص بها واذا كان الفولدر فارغ يتم حذف الفولدر ايضا

مشاركة  مع الاخ العزيز @Foksh

اليك التعديل والاضافة على الكود

Private Sub Del_Click()
    On Error Resume Next
  
    If IsNull(Me.MyList) Then
        MsgBox "يجب اختيار الملف اولا " & vbNewLine & vbNewLine & " اختـار اسـم الملـف من القائمة", vbCritical + vbMsgBoxRight, "تنبيه"
    Else
        Dim sSQL As String
        Dim aFile As String
        Dim folderPath As String
        Dim FDS_path As String
        Dim fso As Object
        Dim FileCount As Integer
        
        aFile = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]")
        folderPath = Left(aFile, InStrRev(aFile, "\") - 1)
        FDS_path = Left(folderPath, InStrRev(folderPath, "\") - 1)
       
        If MsgBox("هل تريد حذف المرفق ؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then
            Kill aFile
         
            Set DB = CurrentDb
            sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList
            DB.Execute sSQL
            
            MsgBox "تم حذف المرفق ... بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
            Me.MyList.Requery
            Me.Show_Files.Requery
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(FDS_path) Then
            DeleteEmptySubfolders fso, FDS_path
                
                If fso.GetFolder(FDS_path).Files.Count = 0 And fso.GetFolder(FDS_path).SubFolders.Count = 0 Then
                    fso.DeleteFolder FDS_path, True
                End If
            End If
            Set fso = Nothing
        End If
    End If
End Sub


Private Sub DeleteEmptySubfolders(fso As Object, folderPath As String)
    Dim folder As Object
    Dim subFolder As Object
    
    Set folder = fso.GetFolder(folderPath)
    
    For Each subFolder In folder.SubFolders
        DeleteEmptySubfolders fso, subFolder.Path
        If fso.GetFolder(subFolder.Path).Files.Count = 0 And fso.GetFolder(subFolder.Path).SubFolders.Count = 0 Then
        fso.DeleteFolder subFolder.Path, True
        End If
    Next subFolder
End Sub

والملف بعد التعديل

بالتوفيق

Lab_2024 - 2.rar

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

وارجو المعذرة لانني كنت في العمل وعملت الكود على عجالة ولم اجربه كفايه.

MyArchfa.accdb

تفضل اخي الكريم التعديل 

شكرا للاخ @Foksh على الملاحظة .

MyArchfa.accdb

السلام عليكم

مشاركة مع الاستاذ  @Foksh جزاه الله خيرا 

اليك التعديل حسب ما طلبت

Private Sub cmdSave_Click()
    If IsNull(Me.book_Bath) Or Me.book_Bath = "" Then
        MsgBox "الملف غير محدد"
        Exit Sub
    End If

    SourceFile = Me.book_Bath
    Dim targetFolder As String
    If Me.book_Type = "وارد" Then
        targetFolder = CurrentProject.Path & "\" & "\Files\Wared\"
    ElseIf Me.book_Type = "صادر" Then
        targetFolder = CurrentProject.Path & "\" & "\Files\Sader\"
    Else
        MsgBox "نوع الكتاب غير معروف"
        Exit Sub
    End If
    
    If Dir(targetFolder, vbDirectory) = "" Then
        MkDir targetFolder
    End If
Dim fileExt As String
fileExt = Split(SourceFile, ".")(UBound(Split(SourceFile, ".")))

DestinationFile = targetFolder & "\" & Me.book_Num & "." & fileExt
FileCopy SourceFile, DestinationFile
Me.book_Bath = DestinationFile
Me.imageType = fileExt
MsgBox "تم حفظ الكتاب"
Me.Requery

End Sub


Private Sub ComView_Click()
    On Error Resume Next
    If IsNull(book_Num) Then
        Beep
        MsgBox "رقم الكتاب مطلوب"
        Exit Sub
    End If
    If IsNull(Me.imageType) Then
        MsgBox "نوع الصورة مطلوب"
        Exit Sub
    End If
    
    Dim filePath As String
    Dim fileName As String
    Dim foundFilePath As String
    
    fileName = Me.book_Num & "." & Me.imageType
    foundFilePath = FindFile(CurrentProject.Path & "\Files\", fileName)
    
    If foundFilePath = "" Then
        MsgBox "لا يوجد كتاب"
        Exit Sub
    End If
    
    ShellExecute Me.hwnd, "open", foundFilePath, "", "", 1
End Sub

Function FindFile(ByVal folderPath As String, ByVal fileName As String) As String
    Dim fso As Object
    Dim folder As Object
    Dim subFolder As Object
    Dim file As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)

    For Each file In folder.Files
        If file.Name = fileName Then
            FindFile = file.Path
            Exit Function
        End If
    Next file
    
    For Each subFolder In folder.SubFolders
        FindFile = FindFile(subFolder.Path, fileName)
        If FindFile <> "" Then Exit Function
    Next subFolder
    
    Set fso = Nothing
    Set folder = Nothing
    Set subFolder = Nothing
    Set file = Nothing
    FindFile = ""
End Function

واليك الملف بعد التعديل

بالتوفيق

MyArchfa.rar

تفضل استاذ @jo_2010 هذا بالنسبة لطلبك الثاني

Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long)
    On Error Resume Next
    
    If Not Me.Dirty Then
        If (Count < 0) And (Me.CurrentRecord > 1) Then
            DoCmd.GoToRecord , , acPrevious
        ElseIf (Count > 0) And (Me.CurrentRecord <= Me.Recordset.RecordCount) Then
            DoCmd.GoToRecord , , acNext
        End If
        Dim parentForm As Form
        Dim labReqForm As Form
        Dim pnameValue As String
        Dim recordFound As Boolean
        
        Set parentForm = Me.Parent
        If parentForm.Controls("Lab_Patient").Form.CurrentView = 0 Then
            MsgBox "Lab_Patient subform is not open."
            Exit Sub
        End If
        
        Set labReqForm = parentForm.Controls("Lab_Sub_REQ").Form
        pnameValue = parentForm.Controls("Lab_Patient").Form.Controls("PNAME").Value
        labReqForm.Recordset.FindFirst "Pname = '" & pnameValue & "'"
        
        If Not labReqForm.Recordset.NoMatch Then
            labReqForm.Controls("Requests").BackColor = RGB(255, 0, 0)
            recordFound = True
        Else
'            MsgBox "Record not found in Lab_Sub_REQ."
            recordFound = False
        End If
    End If
End Sub

بالتوفيق

LAB_GOOD 2.rar

20 ساعات مضت, waheidi2005 said:

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

نعم تفضل اخي الكريم

Private Sub أمر63_Click()
    DoCmd.SetWarnings False
    DoCmd.RunSQL "INSERT INTO TBLgiab (MainId, stclass, sttype, StName, remarks, G_date) " & _
             "SELECT student.Stno, student.Stclass, student.sttype, student.StName, student.empty, " & _
             "[forms]![frmgiab]![Text40] AS Expr1 FROM student WHERE student.ck = True;"
    DoCmd.RunSQL "UPDATE student SET student.ck = 0, student.Empty = Null;"
    DoCmd.SetWarnings True
    Forms![FrmGiab]![نموذج فرعي TBLgiab1].Form.Requery
End Sub

بالتوفيق

الان انتبهت انك غيرت طلبك .  

هذا طلبك الاول : وقد رايت كود الاستاذ @AlwaZeeR وهو يعمل بكفاءه.

في 1‏/4‏/2024 at 19:29, شامل2 said:

كيف يمكن عرض الصور والمستندات المصورة في المثال بامتدادات مختلفة.

بعض الصور امتدادها jpg يتم عرضها  والاخر امتدادها png لا تعرض

في 1‏/4‏/2024 at 20:18, شامل2 said:

وكيف يمكن استدعاء الصور اذا كانت في اكثر من مجلد؟

وهدا طلبك الثاني : هل هو المطلوب ام ان هناك تغير ثالث؟  أخي الكريم انت عضو فضي وتعرف قوانين المنتدى .

على العموم قمت بتغير الكود للتالي فقط الغي الكود السابق وضع هذا الكود 

Private Sub Form_Current()
    Dim Psh As String
    Dim fileName As String
    Dim folderPath As String
    Dim folderName As Variant
    
    On Error GoTo Err
    
    fileName = [ID]
    
    Dim folders() As String
    folders = Split("picto,picto1,Picto2", ",")
    
    For Each folderName In folders
        folderPath = CurrentProject.Path & "\" & folderName & "\"
        
        If Dir(folderPath & fileName & ".jpg") <> "" Then
            Psh = folderPath & fileName & ".jpg"
            Exit For ' Exit loop once file is found
        ElseIf Dir(folderPath & fileName & ".png") <> "" Then
            Psh = folderPath & fileName & ".png"
            Exit For
        End If
    Next folderName
    
    pic.Picture = Psh
    
    Exit Sub
    
Err:
    pic.Picture = ""
    Exit Sub
End Sub

تحياتي 

في 1‏/4‏/2024 at 19:29, شامل2 said:

كيف يمكن عرض الصور والمستندات المصورة في المثال بامتدادات مختلفة.

بعض الصور امتدادها jpg يتم عرضها  والاخر امتدادها png لا تعرض

وعليكم السلام 

مشاركة مع الاساتذة بازك الله فيهم هل هذا هو المطلوب ؟

Private Sub Form_Current()
    Dim Psh As String
    Dim filePath As String
    Dim fileName As String
    
    On Error GoTo Err
    
    fileName = [ID]
    filePath = CurrentProject.Path & "\picto\" & fileName
    
    If Dir(filePath & ".jpg") <> "" Then
        Psh = filePath & ".jpg"
    ElseIf Dir(filePath & ".png") <> "" Then
        Psh = filePath & ".png"
    Else
        Psh = ""
    End If
    
    pic.Picture = Psh
    
    Exit Sub
    
Err:
    pic.Picture = ""
    Exit Sub
End Sub

والملف بعد التعديل 

التعامل مع الصور 2.rar

أحسنت وأحسن الله اليك اخي الاستاذ @Foksh

بالفعل لقد فاتتني الاشارة الى المكتبات ونسخة 64 لان الاخ @UserUser2 كان بالفعل قد استخدم الطابعة الافتراضية لان ملفه كانت المكتبات موجودة بالفعل ولهذا لم افكر بالامر😄

اشكرك جزيل الشكر اخي الفاضل على هذه الاضافات ربي يسعدك.

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

تفضل اخي الكريم @UserUser2 

تم تنفيذ الخطوات التالية:

1. سيتم إنشاء مجلد "Documents" بجانب قاعدة البيانات.

2. سيتم إنشاء مجلد "PDF" تحت مجلد "Documents".

3. سيتم إنشاء مجلد "JPEG" تحت مجلد "Documents".

الغرض من إنشاء هذه المجلدات هو تلبية طلب الأخ السائل، الذي رغب في حفظ الصورة عند التصدير في مجلد محدد برقم العميل واسم الصورة تحمل اسم العميل والتاريخ الموجود في النموذج. ونظرًا لصعوبة تنفيذ هذا الطلب بالنسبة للصور بواسطة برنامج وسيط ، اما بالنسبة للــ  PDF  فآمره سهل جدا وهو ما تم عمله اولا فقد تم تنفيذ الخطوات التالية بعد إنشاء المجلدات:

1. يتم حفظ الملف بالأسماء المذكورة والتاريخ بصيغة PDF.

 2. يتم إرسال الملف للطابعة الافتراضية "Universal Documents Converter".

3. يتم تحديد الصيغة المطلوبة، وفي حالتنا نريد صيغة الصور JPEG.

4. يتم إنشاء الملف المطلوب بكلا الصيغتين PDF و JPEG.

5. يتم حفظ الملف تحت المجلد الخاص به.  

الاكواذ المستخدمة

Option Compare Database
Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub CmdPrint_Click()
    Dim Fs As Object
    Dim StrFolder As String, FilePathPDF As String, FileName As String

    Set Fs = CreateObject("Scripting.FileSystemObject")
    StrFolder = CurrentProject.Path & "\Documents"
    If Not Fs.FolderExists(StrFolder) Then
        On Error Resume Next
        Fs.CreateFolder StrFolder
        On Error GoTo 0
        If Err.Number <> 0 Then
            MsgBox "حدث خطأ أثناء إنشاء المجلد الرئيسي: " & Err.Description, vbCritical + vbOKOnly, "خطأ"
            Err.Clear
            Exit Sub
        End If
    End If

    Dim PDFFolder As String
    PDFFolder = StrFolder & "\PDF"
    If Not Fs.FolderExists(PDFFolder) Then
        On Error Resume Next
        Fs.CreateFolder PDFFolder
        On Error GoTo 0
        If Err.Number <> 0 Then
            MsgBox " PDF خطأ في إنشاء مجلد فرعي " & Err.Description, vbCritical + vbOKOnly, "خطأ"
            Err.Clear
            Exit Sub
        End If
        MsgBox "الفرعي بنجاح PDF تم إنشاء المجلد", vbInformation + vbOKOnly, "تأكيد"
    End If

    FileName = Me.ID & " - " & Me.CNo & " - " & Me.CName & " - " & Format([iDate], "dd-mm-yyyy")
    FilePathPDF = PDFFolder & "\" & FileName & ".PDF"
    
    DoCmd.OpenReport "Report1", acViewPreview, , "[ID] = " & Me.ID
    DoCmd.OutputTo acOutputReport, "Report1", acFormatPDF, FilePathPDF, False
    DoCmd.Close acReport, "Report1", acSaveNo

    ShellExecute 0, "Open", FilePathPDF, vbNullString, vbNullString, vbNormalFocus
    ShellExecute 0, "Print", FilePathPDF, vbNullString, vbNullString, vbNormalFocus
    
    Dim JPEGFolder As String
    JPEGFolder = StrFolder & "\JPEG"
    If Not Fs.FolderExists(JPEGFolder) Then
        On Error Resume Next
        Fs.CreateFolder JPEGFolder
        On Error GoTo 0
        If Err.Number <> 0 Then
            MsgBox " JPEG خطأ في إنشاء مجلد فرعي  " & Err.Description, vbCritical + vbOKOnly, "خطأ"
            Err.Clear
            Exit Sub
        End If
        MsgBox "الفرعي بنجاح JPEG تم إنشاء المجلد", vbInformation + vbOKOnly, "تأكيد"
    End If
End Sub

بالنسبة للطابعة يجب ان تحفظ اعدادت موقع حفظ الملف Documents \Jpeg   مثال :   C:\Users\LENOVO\Downloads\TEST IMAGE\Documents\JPEG

وهذا هو المرفق

بالتوفيق

TEST IMAGE 2.rar

10 ساعات مضت, طير البحر said:

ان طلبي محدد من البداية الصفخات الفارغة اى يجب ان تكون فارغة من اى محتوى

اخي الكريم

وهذا ما عملته بالضبط يجب ان تكون الصفحة خالية تماما من اي محتوى،،، والكود يقوم بهذه المهة فقط.

سؤال هل فعلا جربت الكود لإني على يقين حضرتك لم تجرب الكود. وإلا لكان رأيت عمل الكود بالضبط. 

الاخوة الكرام من يستطيع ان يجرب الكود ويعلمني اذا كان يعمل او لا . ربما اكون مخطئ.

وهذا الكود مرة اخرى 

Option Compare Database
Option Explicit
Private Sub Command0_Click()
     CleanUpWordDocument
End Sub
Public Function DeleteBlankPages(wd As Word.Document)
    Dim par As Paragraph
    For Each par In wd.Paragraphs
        If Len(par.Range.Text) <= 1 Then
            par.Range.Delete
        End If
    Next par
End Function
Public Sub CleanUpWordDocument()
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Set wdDoc = wdApp.Documents.Open("C:\Users\LENOVO\Documents\Test1.docx")' استبدل المسار 
    
    DeleteBlankPages wdDoc
    MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد"
    wdDoc.Save
    wdDoc.Close
    wdApp.Quit
    
    Set wdDoc = Nothing
    Set wdApp = Nothing
End Sub

11 ساعات مضت, طير البحر said:

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

أخي  الكريم طلبك كان  حذف الصفحات الفارغة من ملف وورد برمجيا . 

وهذا ما تم عمله لحذف الصفحات الفارغه ولا له علاقة بطلبك الثاني . سوف اتوقف هنا.

تحياتي

اخي الكريم اسف على التاخير سوف انظر في المرفق غدا ان شاءالله تعالى 

19 ساعات مضت, kkhalifa1960 said:

اقرأ هذا المحتوي ونزل الطابعة  (How to Convert Access Report to JPEG) 

15 ساعات مضت, Foksh said:

انا عن نفسي استخدم الطريقة التي أشار إليها الاستاذ خليفة

هلا بالشباب هذا هو نفس البرنامج الوسيط الذي استخدمته انظروا لمشاركتي السابقة لقد عملت فيديو والملف المرفق مع الاكواد.