omarAbdalrazaq

رائع وجميل واداة مفيدة جدا في عملنا جعلة الله في ميزان حسناتك

مبدع وجميل بارك الله فيك وجعلة في ميزان حسناتكم

يا الله

السلام عليكم ورحمة الله اساتذتنا واخواننا في هذا المنتدى الجميل ارجو افادتي حول تعديل الكود الخاص بالسكنر المطلوب: تصغير حجم الصورة الماخوذة بالسكنر حيث ان كل صورة يبلغ حجمها 5 ميجا تنبيهي الى الاخطاء الموجودة في الكود لغرض التعلم هذا ولكم الاجر والثواب تحياتي للجميع Option Compare Database Option Explicit Dim destinationFolder As String Dim myScanPath As String Dim myScanPathWithID As String Dim myImageFullName As String Private Sub btnClose_Click() DoCmd.Close End Sub Private Sub btnDelete_Click() 'Make Sure PicPath not Null If IsNull(Path) Then MsgBox "لا بوجد مسار للصورة حتى تتم عملية الحذف", vbCritical + vbOKOnly, "نقص معلومات" Exit Sub End If On Error Resume Next If MsgBox("سيتم حذف المرفق نهائيا ولا يمكن التراجع عن الحذف مرة اخري", _ vbQuestion + vbYesNo + vbMsgBoxRight + vbDefaultButton2, _ "تأكيد الحذف") = vbYes Then DoCmd.RunCommand acCmdDeleteRecord Else DoCmd.CancelEvent End If End Sub Private Sub btnHdd_Click() 'Make Sure EmpID not Null If IsNull(EmpID) Or IsNull(TypeOfDocument) Or IsNull(DocumentNumber) Or IsNull(DocumentNumber) Or IsNull(FaceOrBack) Then MsgBox "يرجى اكمال المعلومات في الحقول قبل استعمال نسح صورة من الهارد", vbCritical + vbOKOnly, "نقص معلومات" Exit Sub End If Dim Syso As Object Dim MyFile As String myScanPath = "D:\MyScanDB" myScanPathWithID = myScanPath & "\" & [EmpID] Dim fso As Object Set fso = CreateObject("scripting.filesystemobject") If Not fso.FolderExists(myScanPathWithID) Then fso.createfolder (myScanPathWithID) End If Dim Addfile As Object Set Addfile = Application.FileDialog(3) With Addfile .AllowMultiSelect = False .InitialFileName = "" .Filters.Clear .Filters.Add "All Files", "*.*" If .Show = True Then MyFile = Trim(.SelectedItems(1)) destinationFolder = myScanPathWithID & "\" & [TypeOfDocument] & " " & [DocumentNumber] & " " & Format([DocumentDate], "yyyy-mm-dd") & " " & [FaceOrBack] & " " & Format([DateOfTransfer], "yyyy-mm-dd hh-mm-nn-ss") & ".jpg" Me.Path = destinationFolder DBEngine.Idle Set Syso = CreateObject("Scripting.FileSystemObject") Syso.copyfile MyFile, destinationFolder Set Syso = Nothing Else Exit Sub End If End With End Sub Private Sub btnPrevew_Click() DoCmd.GoToControl "Path" If IsNull(Me![Path]) Then MsgBox "لايوجد مرفق" Else Application.FollowHyperlink [Path] End If Exit_btnHdd_Click: Exit Sub Err_btnHdd_Click: MsgBox Err.Description Resume Exit_btnHdd_Click End Sub Private Sub btnScaner_Click() 'Make Sure EmpID not Null If IsNull(EmpID) Or IsNull(TypeOfDocument) Or IsNull(DocumentNumber) Or IsNull(DocumentNumber) Or IsNull(FaceOrBack) Then MsgBox "يرجى اكمال المعلومات في الحقول قبل استعمال السكنر", vbCritical + vbOKOnly, "نقص معلومات" Exit Sub End If myScanPath = "D:\MyScanDB" myScanPathWithID = myScanPath & "\" & [EmpID] myImageFullName = "" 'Make Sure Folder Exsist if Not Create One destinationFolder = Dir(myScanPathWithID, vbDirectory) If destinationFolder = vbNullString Then VBA.FileSystem.MkDir (myScanPathWithID) End If Dim hg, OldFile, DBwithEXT Dim fdialog As Office.FileDialog Dim filepath As String Dim sdialog As New WIA.CommonDialog Dim imagefile As WIA.imagefile On Error GoTo errorhandle Set fdialog = Application.FileDialog(msoFileDialogSaveAs) OldFile = myScanPathWithID DBwithEXT = Dir(OldFile) hg = myScanPathWithID & "\" & [TypeOfDocument] & " " & [DocumentNumber] & " " & Format([DocumentDate], "yyyy-mm-dd") & " " & [FaceOrBack] & " " & Format([DateOfTransfer], "yyyy-mm-dd hh-mm-nn-ss") & Right(DBwithEXT, 3) With fdialog .Title = "Save as" .AllowMultiSelect = False .InitialFileName = [hg] .InitialFileName = hg + ".bmp" If .Show Then filepath = .SelectedItems(1) ' Else Exit Sub End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath Me.Path = filepath End With errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit End Sub MyPic.rar

اشكرك اخي على الاجابة استبدلت الشرط ب where وظهر الخطاء الذي بالصورة المرفقة اريد اجراء استعلام مثل الذي بالصورة

كل عام وانتم بخير

السلام عليكم اخواني واستاذتنا الافاضل. عيد فطر سعيد اعاده الله عليكم وعلينا . ارجو المساعدة في استعلام مجاميع اوجمع Totals عند وضع شرط في احد الاعمدة يظهر الخطاء(data type mismatch in criteria expression) الموجود في الصورة المرفقة. تحياتي للجميع.

اشكرك استاذنا الفاضل جعلة الله في ميزان حسناتك

عفو استاذ لا يسمح الموقع ان ارفعة كون حجمة اكثر من 1 ميجا هذا رابط اخر عسى ان تستطيع تحميلة مع فائق شكري مقدما https://drive.google.com/file/d/1qeLaWW8gqQ-VKpEWgifKd4aEf8QjAH32/view?usp=sharing

https://drive.google.com/file/d/1DtZlIRN5IiHsJX0wtb3f0ZILMzVR68aX/view?usp=sharing

السلام عليكم ورحمة الله اساتذتنا واخواننا في هذا المنتدى تحية لكم ارجو مساعدتي في خطاء برمجي عند الضغط على زر السكنر تظهر لي هذه الجملة (Type mismatch) Private Sub أمر166_Click() On Error Resume Next Dim y y = [dd] & "\" & [رقم الطلب] Dim fs As Object Dim q As Object Set fs = CreateObject("Scripting.FileSystemObject") If fs.FolderExists(y) = True Then Else Set q = fs.Createfolder(y) End If Dim hg, OldFile, DBwithEXT Dim fdialog As Office.FileDialog Dim filepath As String Dim sdialog As New WIA.CommonDialog Dim imagefile As WIA.imagefile On Error GoTo errorhandle Set fdialog = Application.FileDialog(msoFileDialogSaveAs) OldFile = Me.x DBwithEXT = Dir(OldFile) hg = y & "\" & [a] & " " & [b] & " " & Format([c], "yyyy-mm-dd") & " " & [d] & "." & Right(DBwithEXT, 3) With fdialog .Title = "Save as" .AllowMultiSelect = False .InitialFileName = [hg] If .Show Then filepath = .SelectedItems(1) ' Else Exit Sub End If Set imagefile = sdialog.ShowAcquireImage() imagefile.SaveFile filepath [ImagePath] = filepath End With errorhandleexit: Exit Sub errorhandle: MsgBox Err.Description Resume errorhandleexit End Sub

استاذنا الفاضل عملت ما قلت لي وما زالت المشكلة موجودة انا اعلم ان المشكلة في الرتب ولكن استطيع توحيد الرتب لان لكل سائق رتبة وانا استخدمها في دالة (horizontal) اذا لم يكن هناك حل لمشكلتي فهل تنصحني بان اجعلها في حقل نصي(اسماء السواق جميعهم) في النموذج الرئيسي ولكن سافقد معلومات كثيرة احتاجها وضعتها في جدول اسماء السواق تحياتي للجميع

اشكرك اخي ولكن للتوضيح لدي جدول رئيسي فية تفاصيل السيارات وجدول فرعي فية اسماء السواق (اكثر من سائق) اردت جمع خقول السواق في حقل واحد في الاستعلام فساعدني اساتذتنا في هذ المنتدى جزاهم الله خيرا بعمل ذلك من خلال دالة (horizontal) ولكن المشكلة ان الحقول في الاستعلام تكررت وانا اريدها بدون تكرار

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

السلام عليكم ورحمة الله تحية طيبة الى اعضاء هذا المنتدى عندي مشكلة واتمنى من استذتنا و اخواننا مساعدتي بها المشكلة هي: تكرار السجلات في الاستعلام المسمى Qry_ToAgnecy ملاحظة: ساعدني اساتذتنا في هذا الموقع سابقا في دمج حقول جدول فرعي في حقل واحد عن طريق دال Horizontal واستخدامة في هذ الاستعلام وسؤوال اخر ان امكن هل استطيع بدل حذف سجل ان ارسلة الى قاعدة بيانات فارغة مشابهة الى قاعدة البيانات الاصلية حتى استطيع في المستقبل الرجوع الية في حالى احتياجي للسجلات المحذوفة الملف في الرابط ادناة تحياتي للجميع https://drive.google.com/open?id=1Wp0sPl-oa6USnQ1CGNCHUJbEqKBMiv4R

الشكر الجزيل لك استاذ جمال ولكل اساتذتنا في هذا المنتدى الرائع جعلة الله في ميزان حسناتكم كفيت ووفيت

استاذ جمال بعد التحية والشكر على مشاركتك فقط السؤال الي محيرني لماذا يجب ان اخذ المعلومات من استعلام ؟ لماذا لا اخذ المعلومات من جدول حتى استطيع ان اضعها في الاستعلام الرئيسي كل المعلومات [qryAllUser: Horizontal("Qry_ToAgency";"WheelName";"FullName";[WheelName هل استطيع استبدال هذا الاستعلام بجدول اسماء السواق Tbl_WheelUsers

بانتظار مساعدة اي اخ في حل مشكلتي

شكرا استاذنا الفاضل وساحاول تطبيق ما افدتني بة وادعو من الله ان يوفقني في ذلك وهل تتكرم علي وتضيف الحقل الذي يدمج الاسماء في برنامجي الرئيسي لان الملف الذي رفعتة هو مثال للتعلم وساكون شاكرا لك اسم الاستعلام الذي اريد اضافة الحقل لة: Qry_ToAgency ولقد انشئت الموديل بالدالة Horizontal رابط الملف للبرنامج الرئيسي https://drive.google.com/open?id=1Wp0sPl-oa6USnQ1CGNCHUJbEqKBMiv4R

شكرا استاذنا الفاضل احمد هل يمكن اعلامي عن الطريقة التي عملت بها الاستعلام qryAllUsers؟ وهل يمكن عمل استعلام من استعلام اخر؟

السلام عليكم اخواني في هذا المنتدى الرائع اود الاستفسار عن طريقة اضافة حقل في الاستعلام ياخذ معلوماتة من عدة سجلات او من سجل محدد في جدول فرعي مثال 1- حقل في الاستعلام يجمع عمودين لجميع السجلات ويترك بينها حرف (و) مثال السيد محسن علي و السيد توفيق محمد و ....الخ 2-حقل في الاستعلام ياخد قيمتة من جمع اسماء عمودين العمود الاول والثاني في السجل الاول في جدول فرعي 3-حقل في الاستعلام ياخذ قيمتة من جمع اسماء عمودين العمود الاول والثاني في السجل الاخير في جدول فرعي ملاحظة اود عدم تكرار السجات في الاستعلام. مع العلم ان الجدول المعمول لة استعلام مرتبط مع الجدول الفرعي بعلاقة راس باطراف وانا بامس لمعرفة انشاء مثل هذة الاستعلامات لحاجتي اليها في عملي وعمل التقارير او التصدير الى اكسيل الملف في المرفقات تحياتي للجميع Example.accdb

استاذ جعفر اتمنى اني لم اثقل عليك ولكني لم استطيع تطبيق الفديوات بصورة صحيحة فهل لك ان تدلني على موضوع في هذا المنتدى العزيز لشرح عمل فورم ارشفة(ادخال صور+سكنر) بصورة اسهل لحاحتي الماسة الية في عملي مع الشكر الجزيل على سعة صدرك

عندي مشكلة اخرى في داله اخرة وهي If istrimed اين اجد هذه الدالة هل اجدها موجودة في صفحات الويب ام يجب علي البحث في الفديوهات اليوتيوب

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

اسف على الصورة وهذه نسخة من الكود والمشكلة في دالة isnothing يعطيني ال VBA رسالة الخطاء sub or function not defined Option Compare Database Dim ImageFilename, ImageFolder, AltFolder As String 'للتعامل مع السحب والافلات للصور Private Sub DBPixM_ImageModified() On Error Resume Next DoCmd.RunCommand acCmdSaveRecord Dim s As String If DBPixM.ImageBytes < 1 Then DocPic = Null Else 'تسمية الصورة s = WheelID & "_" & DocType & "_" & DocNumber & "-" & Format(DocDate, "dd-mm-yyyy") & "_" & DocID s = Replace(s, "/", "_") If DBPixM.ImageFormat = 1 Then 'jpeg s = s & ".jpg" Else s = s & ".png" End If If isnothing(ImageFolder) Then ImageFolder = CurrentFolder ImageFilename = ImageFolder & s 'للتاكد من عدم تعارض اسماء الملفات If fileexist(ImageFilename) Then If MsgBox("لديك ملف بنفس الاسم وبنفس الموضع" & vbNewLine & "هل تريد استبدال الوثيقة؟", vbQuestion + vbYesNo + vbMsgBoxRight, "سئوال") = vbNo Then DBPixM.ImageViewFile ImageFilename: Exit Sub End If If DBPixM.ImageSaveFile(ImageFilename) Then If isrelative(ImageFilename) Then DocPic = Right(ImageFilename, Len(ImageFilename) - Len(CurrentProject.path) - 1) ElseIf isnetpath(ImageFilename) Then DocPic = Right(ImageFilename, Len(ImageFilename) - Len(CurrentFolder) + netpathlen(CurrentFolder)) Else DocPic = ImageFilename ImageFolder = Left(ImageFilename, InStrRev(ImageFilename, "\")) End If DoCmd.RunCommand acCmdSaveRecord Else UsMes.Caption = vbnnewline & "تعذر حفظ صورة الوثيقة" DBPixM.ImageViewBlob (Null) UsMes.Visible = True DBPixM.Visible = False End If End If End Sub Private Sub Form_Current() On Error Resume Next Dim Tr As Boolean UsMes.Visible = False: DBPixM.Visible = True If Not isnothing(DocPic) Then If istrimed(DocPic) Then If IsNoPath(DocPic) Then ImageFilename = CurrentFolder & "\" & DocPic ElseIf isnetpath(CurrentFolder) Then If InStr(CurrentFolder, Left(DocPic, InStr(DocPic, "\"))) > 0 Then ImageFilename = CurrentFolder & Mid(DocPic, 1 + InStrRev(DocPic, "\")) Else ImageFilename = CurrentFolder & IIf(Left(DocPic, 1) = "\", "", "\") & DocPic End If Else ImageFilename = CurrentProject.path & IIf(Left(DocPic, 1) = "\", "", "\") & DocPic CurrentFolder = CurrentProject.path & "\" Tr = True End If Else ImageFilename = DocPic End If If fileexist(ImageFilename) Then DBPixM.ImageViewFile ImageFilename Else If Tr Then ImageFilename = ImageFolder & DocPic If fileexist(ImageFilename) Then DBPixM.ImageViewFile ImageFilename CurrentFolder = ImageFolder Else UsMes.Caption = vbNewLine & "صورة الوثيقة مفقودة" UsMes.Visible = True DBPixM.ImageViewBlob (Null) CurrentFolder.SetFocus DBPixM.Visible = False End If End If ImageFolder = IIf(isnothing(AltFolder), Left(ImageFilename, InStrRev(ImageFilename, "\")), AltFolder) Else UsMes.Caption = vbNewLine & "اضف وثيقة جديدة" UsMes.Visible = True DBPixM.ImageViewBlob (Null) CurrentFolder.SetFocus DBPixM.Visible = False End If End Sub Private Sub Form_Load() 'جعل مكان الحفظ عند التشغيل هو مكان البرنامج CurrentFolder = CurrentProject.path End Sub