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

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

يعنى حضرتك هتعملى المطلوب دلوقتى ولا ايه

السلام عليكم ورحمة الله شكرا جزيلا الكريم ابو جودي احسنت فاجابتك صحيحة وشكرا جزيلا لاختنا الكريمة safaa لاهتمامها بالموضوع ومحاولتها الرد على طلبي فجزاكم الله خيرا جميعا.

رابط الموقع الذى يتم فيه تحويل جمل sql access الى sql server SQL Converter - AccessUserGroups.org

اشكرك وايد استاذ @Ahmos ❤️🌹 👍 تمة التجربة ميدوال رائع صحيح عند اختيار صورة حجم K4 تمتد الصورة وعند تجربة صورة اقل من الجوده تتم الاقتصاص شفت استاذي @ابو جودي من مرفق امس دخان 😂 من غير رعود ============================ Editor_Size And Cropping an Image With Controll Print v.1.part1.rar Editor_Size And Cropping an Image With Controll Print v.1.part2.rar

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

جرب لعله يكون مفيدا Private Sub Worksheet_Change(ByVal Target As Range) Dim ch As Variant Dim cell As Range ' تحقق إذا كانت التغييرات داخل النطاق المطلوب If Not Intersect(Target, Me.Range("E10:E1009")) Is Nothing Then Application.EnableEvents = False Application.ScreenUpdating = False ' ضبط الأسماء وإزالة المسافات الزائدة لكل خلية تم تغييرها For Each cell In Intersect(Target, Me.Range("E10:E1009")) ' ضبط الأسماء قبل عملية الأبجدة For Each ch In Array("إ", "أ", "آ") cell.Value = Replace(cell.Value, CStr(ch), "ا", 1, -1, vbTextCompare) Next cell.Value = Replace(cell.Value, "ة", "ه", 1, -1, vbTextCompare) cell.Value = Replace(cell.Value, "ي ", "ى ", 1, -1, vbTextCompare) ' إزالة المسافات الزائدة Do While InStr(cell.Value, " ") > 0 cell.Value = Replace(cell.Value, " ", " ") Loop cell.Value = Trim(cell.Value) Next cell Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub

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

انا كاني سامع حد بينادي .... مين بيتكلم ...... انا اسمي موجود ..... انا هنا .... وانا حاضر يا بشمهندس

طيب وحتى لا يقال اننى ناقل عن الاستاذ @ناقل لن اقوم بتعديل الاكواد انا معقد و افضل العمل دائما وفق مرونة واحترافية بقدر الامكان وفقا لذلك هذه طريقتى اولا عمل موديول باسم : basExportReportToPDF الاكواد فى الموديول Option Compare Database Option Explicit ' Function to create directories if they do not exist Public Function CreateDirectoryIfNotExists(ByVal path As String) If Dir(path, vbDirectory) = "" Then MkDir path End If End Function ' Function to export report to PDF Public Function ExportReportToPDF(ByVal patientID As String, ByVal patientName As String, ByVal visitCode As String, ByVal reportName As String, ByVal outputFileName As String) Dim baseFolderPath As String Dim resultsFolderPath As String Dim patientFolderPath As String Dim visitFolderPath As String Dim outputFilePath As String ' Get the base folder path of the current database baseFolderPath = CurrentProject.path ' Define the path for the results folder resultsFolderPath = baseFolderPath & "\results" ' Create the results folder if it does not exist CreateDirectoryIfNotExists resultsFolderPath ' Define the path for the patient folder patientFolderPath = resultsFolderPath & "\" & patientID & "_" & patientName ' Create the patient folder if it does not exist CreateDirectoryIfNotExists patientFolderPath ' Define the path for the visit folder visitFolderPath = patientFolderPath & "\" & visitCode ' Create the visit folder if it does not exist CreateDirectoryIfNotExists visitFolderPath ' Define the output file path outputFilePath = visitFolderPath & "\" & outputFileName & ".pdf" ' Export the report to PDF DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, outputFilePath ' Notify the user MsgBox "Report has been exported to: " & outputFilePath, vbInformation End Function ثانيا زر امر فى النموذج على ان يكون الكود داخل زر الامر كالاتى Dim patientID As String Dim patientName As String Dim visitCode As String Dim reportName As String Dim outputFileName As String ' Set the values for the parameters patientID = "12345" patientName = "Moh3sam" visitCode = "2024-06-11" reportName = "rptTest" outputFileName = "YourOutputFileName" ' Call the function to export the report to PDF ExportReportToPDF patientID, patientName, visitCode, reportName, outputFileName وطبعا تحياتى وكل تقدير لاستاذى الجليل ومعلمى القدير الاستاذ @ناقل قطعا بدأت مشاركتى بمداعبة استاذى القدير . وهذه قاعدة البيانات بالتطبيق export report to PDF.accdb

جرب لعله يفيدك Sub Names_Adjust() ' ضبط الأسماء قبل عملية الأبجدة ' -------------------------- Dim ch Application.ScreenUpdating = False With Range("E10:E1009") For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا", , , True Next .Replace "ة", "ه", , , True .Replace "ي ", "ى ", , , True End With ' إزالة المسافات الزائدة Dim sh As Worksheet, lr As Long, i As Long Set sh = ThisWorkbook.ActiveSheet lr = sh.Cells(Rows.Count, 5).End(xlUp).Row For i = 10 To lr Do While InStr(sh.Cells(i, 5), " ") > 0 sh.Cells(i, 5).Value = Replace(sh.Cells(i, 5), " ", " ") Loop sh.Cells(i, 5).Value = Trim(sh.Cells(i, 5).Value) Next i Application.ScreenUpdating = True End Sub

اللى شايفه حضرتك صح .. لانه لسة انا فى بداية انشاء البرنامج

Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) Dim s1 As String Dim imagePath As String s1 = Str(Me![رقم الجلوس]) s1 = Right(s1, Len(s1) - 1) imagePath = "D:\صور\" + s1 + ".jpg" If Dir(imagePath) <> "" Then Me![Image_Std].Picture = imagePath Else Me![Image_Std].Picture = "" Me![Image_Std].Caption = "لا توجد صورة مطابقة لرقم الجلوس" End If End Sub ```

تفضل استاذ @Zooro1 اليك المرفق الجديد ومتجرب أكثر من مرة . (جرب ) . ووافني بالرد . قبل سفري .... DDCountUsersSendLeters-2.rar

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي جرب هدا Private Sub CommandButton1_Click() Dim WS As Worksheet: Set WS = Sheet3 Dim FileName As String, strDirname As String, Patch As String, strDefpath As String strDirname = Me.TextBox1.Text FileName = WS.[B8] strDefpath = Label2.Caption lr = WS.Range("B" & WS.Rows.Count).End(xlUp).Row WS.PageSetup.PrintArea = "A1:D" & lr + 5 On Error Resume Next If FileName = "" Then MsgBox "يرجى اظافة اسم الملف": Exit Sub If Not Right(strDefpath, 1) = "\" Then strDefpath = strDefpath & "\" If Not Right(FileName, 4) = ".Pdf" Then FileName = FileName & ".Pdf" If Dir(strDefpath & strDirname, vbDirectory) = "" Then MkDir strDefpath & strDirname Patch = strDefpath & strDirname & "\" & FileName WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Patch End Sub ملف V2.xlsm

تم تعديل الكود 2.xls 1.xlsb 3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي ضع الكود التالي في Module Function arr(a, b) maxtab1 = UBound(a) Dim tmp(): ReDim tmp(1 To UBound(a) + UBound(b), 1 To UBound(a, 2)) For i = LBound(a) To UBound(a) For c = 1 To UBound(a, 2): tmp(i, c) = a(i, c): Next Next i For i = 1 To UBound(b) For c = 1 To UBound(b, 2): tmp(maxtab1 + i, c) = b(i, c): Next Next i arr = tmp End Function وفي داخل اليوزرفورم Dim rng(), Cnt, Width, OneRng, ColVisu '09/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' Private Sub UserForm_Initialize() Dim Cpt, F Cpt = [Data]: F = [Data1]: rng = arr(Cpt, F) 'Merge table data For i = LBound(rng) To UBound(rng): rng(i, 2) = Format(rng(i, 2), "dd/mm/yyyy"): Next i OneRng = "Data" Width = Array(100, 80, 80, 160, 80, 60) ColVisu = Array(6, 5, 4, 3, 2, 1): Cnt = UBound(ColVisu) + 1 For c = 1 To Cnt tmp = Range(OneRng).Offset(-1).Item(1, c) Me("Label" & c).Caption = tmp: Me("Labtxt" & c).Caption = tmp Next txtClear Me.ListBox1.ColumnCount = Cnt Me.ListBox1.ColumnWidths = Join(Width, ";") Dim result(): n = 0 For i = 1 To UBound(rng) n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each k In ColVisu c = c + 1: result(c, n) = rng(i, k) Next k Next i If n > 0 Then Me.ListBox1.Column = result: Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If End Sub '***************** Sub filterdata() Dim result(): n = 0 Dim Cpt1 As String, Cpt2 As String For i = 1 To UBound(rng) 'الاسم If TextBox1.Value = "" Then Cpt1 = rng(i, 3) Else Cpt1 = "*" & TextBox1.Value & "*" 'رقم المعاملة If TextBox2.Value = "" Then Cpt2 = rng(i, 6) Else Cpt2 = "*" & TextBox2.Value & "*" If LCase(rng(i, 3)) Like LCase(Cpt1) And LCase(rng(i, 6)) Like LCase(Cpt2) Then n = n + 1: ReDim Preserve result(1 To Cnt, 1 To n) c = 0 For Each r In ColVisu c = c + 1: result(c, n) = rng(i, r) Next r End If Next i If n > 0 Then Me.ListBox1.Column = result Counter = ListBox1.ListCount Else Me.ListBox1.Clear End If txtClear End Sub '*********************** Private Sub TextBox1_Change() Call filterdata End Sub Private Sub TextBox2_Change() Call filterdata End Sub Private Sub ListBox1_Click() For i = 1 To Cnt Me("txt" & i) = Me.ListBox1.Column(i - 1) Next i End Sub '********************* Private Sub transfert_Click() Set WS = Sheets("Sheet1") WS.Cells.ClearContents n = ListBox1.ListCount: result = Me.ListBox1.List WS.[A2].Resize(n, 6) = Application.Index(result, _ Evaluate("Row(1:" & n & ")"), ColVisu) c = 0 For c = 1 To Cnt WS.Cells(1, c) = Range(OneRng).Offset(-1).Item(1, c) Next Me.TextBox1 = "": Me.TextBox2 = "" MsgBox "تم ترحيل البيانات بنجاح", Exclamation, "admin" End Sub '************************* Sub txtClear() For k = 1 To Cnt Me("txt" & k) = "" Next k End Sub كشف المعاملات المؤرشفة.xlsb

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

تفضل Libraries-1.rar

بشرط ان التقرير يتم تصديره الى مسار البرنامج الحالى حتى مع تغيير المستخدمين لمكان احتفاظهم بالبرنامج عايزه نتيجة كل مريض تتخزن فى فولدر بكود المريض ID داخل فولدر اسمه results هيكون موجود داخل ملفات البرنامج وعايزه اسم التقرير يحتوى على اسم المريض PNAME مع كود المريض ID مع اسم مجموعة التحاليل SUB