سامي الحداد
الخبراء-
Posts
287 -
تاريخ الانضمام
-
تاريخ اخر زياره
-
Days Won
1
نوع المحتوي
المنتدى
مكتبة الموقع
معرض الصور
المدونات
الوسائط المتعددة
كل منشورات العضو سامي الحداد
-
تصدير او حفظ تقرير الى صورة jpg
سامي الحداد replied to محمد عبد الشفيع's topic in قسم الأكسيس Access
أحسنت وأحسن الله اليك اخي الاستاذ @Foksh بالفعل لقد فاتتني الاشارة الى المكتبات ونسخة 64 لان الاخ @UserUser2 كان بالفعل قد استخدم الطابعة الافتراضية لان ملفه كانت المكتبات موجودة بالفعل ولهذا لم افكر بالامر😄 اشكرك جزيل الشكر اخي الفاضل على هذه الاضافات ربي يسعدك. -
تصدير او حفظ تقرير الى صورة jpg
سامي الحداد replied to محمد عبد الشفيع's topic in قسم الأكسيس Access
السلام عليكم ورحمة الله وبركاته تفضل اخي الكريم @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 -
حذف الصفحات الفارغة من ملف وورد برمجيا
سامي الحداد replied to طير البحر's topic in قسم الأكسيس Access
اخي الكريم وهذا ما عملته بالضبط يجب ان تكون الصفحة خالية تماما من اي محتوى،،، والكود يقوم بهذه المهة فقط. سؤال هل فعلا جربت الكود لإني على يقين حضرتك لم تجرب الكود. وإلا لكان رأيت عمل الكود بالضبط. الاخوة الكرام من يستطيع ان يجرب الكود ويعلمني اذا كان يعمل او لا . ربما اكون مخطئ. وهذا الكود مرة اخرى 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 -
حذف الصفحات الفارغة من ملف وورد برمجيا
سامي الحداد replied to طير البحر's topic in قسم الأكسيس Access
أخي الكريم طلبك كان حذف الصفحات الفارغة من ملف وورد برمجيا . وهذا ما تم عمله لحذف الصفحات الفارغه ولا له علاقة بطلبك الثاني . سوف اتوقف هنا. تحياتي -
تصدير او حفظ تقرير الى صورة jpg
سامي الحداد replied to محمد عبد الشفيع's topic in قسم الأكسيس Access
اخي الكريم اسف على التاخير سوف انظر في المرفق غدا ان شاءالله تعالى -
تصدير او حفظ تقرير الى صورة jpg
سامي الحداد replied to محمد عبد الشفيع's topic in قسم الأكسيس Access
هلا بالشباب هذا هو نفس البرنامج الوسيط الذي استخدمته انظروا لمشاركتي السابقة لقد عملت فيديو والملف المرفق مع الاكواد. -
تصدير او حفظ تقرير الى صورة jpg
سامي الحداد replied to محمد عبد الشفيع's topic in قسم الأكسيس Access
اخي الكريم ارفق ملفك للتعديل عليه وأبشر خيرا ان شاءالله -
حذف الصفحات الفارغة من ملف وورد برمجيا
سامي الحداد replied to طير البحر's topic in قسم الأكسيس Access
عجيب كيف لم يؤدي الوظيفة؟ الا اذا كنت تقصد شيئا اخر ! ملاحظة برنامج Word يجب ان يكون مفلقا حتى يتم عمل الكود. انظر للفيديو المرفق Delete Empty Word Pages.rar -
تصدير او حفظ تقرير الى صورة jpg
سامي الحداد replied to محمد عبد الشفيع's topic in قسم الأكسيس Access
السلام عليكم ورحمة الله وبركاته بالإضافة لما تفضل به الأستاذ موسى جزاه الله خيرا انا استخدم هذا البرنامج Universal Document Converter وهذا موقع الشركة: https://www.print-driver.com/download بعد إتمام عملية تنصيب البرنامج تابع الفيديو . ومرفق ملفك بعد التعديل. بالتوفيق jpg.rar شرج عمل برنامج Universal Document Converter.rar -
حذف الصفحات الفارغة من ملف وورد برمجيا
سامي الحداد replied to طير البحر's topic in قسم الأكسيس Access
السلام عليكم هذه مشاركتي مع الاخوة الكرام. 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 بالتوفيق -
اللهم آمين وإياك إن شاء الله، الله يجعلك من اهل الجنة ويرحم والديك في الدنيا والاخرة الشكر لله عز وجل ربي يسعدك.
-
مشاركة مع الاخ @Foksh Option Compare Database Option Explicit Private Sub Command0_Click() ExecuteIfChromeOpen End Sub Function IsChromeRunning() As Boolean Dim strCommand As String Dim strOutput As String Dim objWShell As Object Set objWShell = CreateObject("WScript.Shell") strCommand = "tasklist /FI ""IMAGENAME eq chrome.exe""" strOutput = objWShell.Exec(strCommand).StdOut.ReadAll If InStr(strOutput, "chrome.exe") > 0 Then IsChromeRunning = True Else IsChromeRunning = False End If Set objWShell = Nothing End Function Sub ExecuteIfChromeOpen() If IsChromeRunning() Then MsgBox " المتصفح كروم قيد التشغيل. سيتم تنفيذ الأمر", vbInformation, "تأكيد" DoCmd.OpenForm "البيانات" Else MsgBox "يجب فتح المتصفح .", vbExclamation, "المتصفح مغلق" End If End Sub واليك المرفق بالتوفيق Database313.accdb
-
هل هذا هو المطلوب ؟ حسب ما فهمت هل هذا هو المطلوب؟ Private Sub Form_Load() Dim pdfPath As String pdfPath = "C:\Users\LENOVO\Documents\1222.pdf" ' استبدل المسار Me.WebBrowser0.Object.Navigate pdfPath End Sub
-
نعم ممكن عملها كما عملت وهذه طريقتي اليك التعديل Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String Dim SpecificFileName As String SpecificFileName = "Image1" sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("SELECT * FROM MsysResources WHERE [type]='img' AND [Name]='" & SpecificFileName & "';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation + vbMsgBoxRight, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub بالتوفيق
-
نعم ممكن اليك الكود Option Compare Database Option Explicit Private Sub Command2_Click() ExtractImage End Sub Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("select * from MsysResources where [type]='img';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub سيتم إنشاء مجلد بجانب قاعدة البيانات باسم Images يمكنك تغير اسم المجلد كما تريد وسيتم استخراج كافة الصور و الايقونات من قاعدة البيانات وحفظها في المجلد. وهذا ملفك مع الكود وتم إضافة ايقونات 2 للتجربة بالتوفيق saveimage2.accdb
-
أخي انت لم تستخدم الكود الذي ذكرته لك وحتى لم تكلف نفسك بتجربته على العموم نفس الكود اعلاه يعمل. فقط كلف نفسك وانقله الى ملفك يعني نسخ ولصق . وهذا ملفك مع نفس الكود اعلاه error (1).accdb
-
وعليكم السلام تفضل اخي التعديل على الكود حسب ما فهمت Private Sub Command0_Click() Dim Result As Variant Result = DLookup("feq", "test_tbl") If Len(Result & "") = 0 Then MsgBox "Equation not found or is empty.", vbExclamation Else If IsNumeric(Result) Then Me.E = Result Else Me.E = DLookup("result", "test_order_tbl", "[tcode] = 17") / DLookup("result", "test_order_tbl", "[tcode] = 16") End If End If End Sub بالتوفيق
-
تعديل على كود vba _ اضافة رقم في استعلام تحديث
سامي الحداد replied to figo82eg's topic in قسم الأكسيس Access
مشاركة مع الاساتذة جرب هذا التعديل Private Sub Command84_Click() Dim cityCode As String Dim strSQL As String ' استخراج كود المدينة من المربع النصي cityCode = Me.Text82.Value ' التحقق من أن تم إدخال كود المدينة If Len(cityCode) > 0 Then ' نقل السجلات المستهدفة إلى جدول مؤقت "Test" strSQL = "SELECT * INTO Test FROM [BASIC_DATE] WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Delete4 strSQL = "UPDATE Test SET crn = Right(crn, Len(crn)-4) WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Delete3 right strSQL = "UPDATE Test SET crn = Left(crn,Len(crn)-3) & Right(crn,2) WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Repete strSQL = "UPDATE Test SET crn = Left([crn],2)+[crn] WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' Addo strSQL = "UPDATE Test SET crn = crn & '00' WHERE Left(crn, 4) = '" & cityCode & "';" DoCmd.RunSQL strSQL ' حذف السجلات من الجدول الأصلي "BASIC_DATE" DoCmd.RunSQL "DELETE FROM [BASIC_DATE] WHERE Left(crn, 4) = '" & cityCode & "';" ' إدراج السجلات المحدثة من "Test" إلى الجدول الأصلي "BASIC_DATE" DoCmd.RunSQL "INSERT INTO [BASIC_DATE] SELECT * FROM Test;" ' حذف الجدول المؤقت "Test" DoCmd.DeleteObject acTable, "Test" ' رسالة تأكيد MsgBox "تم تحديث السجلات بنجاح!", vbInformation DoCmd.Requery Else ' رسالة في حالة عدم إدخال كود المدينة MsgBox "الرجاء إدخال كود المدينة أولاً!", vbExclamation End If End Sub -
مشاركة مع الاستاذ @SAROOK جزاه الله خيرا Private Sub document_name_AfterUpdate() Dim Msg, Style, Title, Response Dim XX As Variant XX = [document name] If (Eval("dlookup(""[document name]"",""[input]"",""[nomber] =form![document name]"") Is Not Null")) Then Msg = "الكتاب رقم" & " " & XX & " " & vbCrLf & _ "قد تم ادخاله سابقا " & vbCrLf & vbCrLf & _ "Yes : نعم اذهب الى ذلك السجل" & vbCrLf & _ "No : فقط الغي هذا السجل" Style = vbYesNo + vbCritical + vbDefaultButton2 + vbMsgBoxRight Title = "تحذير الرقم مكرر !! " Response = MsgBox(Msg, Style, Title) If Response = vbYes Then ' DoCmd.GoToControl "document name" DoCmd.FindRecord XX, , , , , acAll, True End If Me.Undo End If End Sub وهذا الملف بعد التعديل بالتوقيق abcd.rar
-
الشكر لله عز وجل حياك الله وجزاك الله خيرا تحياتي
-
وعليكم السلام تفضل اخي الكريم Private Sub Cmdshow_Click() Me.txt = "" Me.Form.RecordSource = "" Me.Form.RecordSource = "SELECT * FROM Qtb " Me.Form.RecordSource = "Qtb" End Sub واليك الملف بعد التعديل test (2).accdb
-
السلام عليكم مشاركة مع معلمنا القدير ابو خليل تفضل اخي البحث عن طريق الكود وليس الاستعلام Private Sub Text1_J_Change() Dim strFilter As String, strSearch As String If Nz(Me.Text1_J.Text) = "" Then Me.DataSearch_J.Form.Filter = "" Me.DataSearch_J.Form.FilterOn = False Else strSearch = Replace(Me.Text1_J.Text, "'", "''") strFilter = strFilter & "Branch LIKE '*" & strSearch & "*' OR " strFilter = strFilter & "SubStatement LIKE '*" & strSearch & "*' OR " strFilter = strFilter & "BondNo LIKE '*" & strSearch & "*' OR " strFilter = strFilter & "BondSerial LIKE '*" & strSearch & "*'" End If If strFilter <> "" Then Me.DataSearch_J.Form.Filter = strFilter Me.DataSearch_J.Form.FilterOn = True Else Me.DataSearch_J.Form.Filter = "" Me.DataSearch_J.Form.FilterOn = False End If Me.Text1_J.SetFocus Me.Text1_J.SelStart = Len(Me.Text1_J.Text) End Sub عملت لك البحث في اربعة حقول Branch و SubStatement و BondNo و BondSerial بالامكان إضافة حقول اخرى للتصفية عسى ان يكون هو المطلوب بالتوفيق البحث في النموذج.rar
-
اخوي العزيز اسف على التاخير اليك التعديل كما طلبت. اليك الملف بالتوفيق للمسح من سكانر نوع اوتوماتيك فيدر وبدن تحديد عدد الصور.rar
-
وعليكم السلام جرب هذا التعديل اخي الكريم Private Sub نص15_AfterUpdate() If Me.NewRecord = False Then If Not IsNull(DLookup("end_date", "HOL", "end_date = #" & Me.end_date & "# AND ID <> " & Me.id)) Then MsgBox "هذا التاريخ متكرر..يرجى اعادة الادخال " Me.Undo End If End If If [نص15] < [نص21] Then MsgBox "تاريخ نهاية الاجازة أصغر من تاريخ البداية ", , "مع تحياتي" Me.Undo End If End Sub Private Sub نص21_AfterUpdate() If Me.NewRecord = False Then If Not IsNull(DLookup("start_date", "HOL", "start_date = #" & Me.start_date & "# AND ID <> " & Me.id)) Then MsgBox "هذا التاريخ متكرر..يرجى اعادة الادخال " Me.Undo End If End If End Sub واليك الملف بالتوفيق الاجازات.accdb
-
فعلا غريب سابحث في هذا الموضوع و اوافيك ان شاءالله