omarAbdalrazaq

يوليو 29, 2022

رائع وجميل واداة مفيدة جدا في عملنا

جعلة الله في ميزان حسناتك

أبريل 21, 2022

مبدع وجميل

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

يونيو 29, 2021

يا الله

يونيو 24, 2021

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

اساتذتنا واخواننا في هذا المنتدى الجميل

ارجو افادتي حول تعديل الكود الخاص بالسكنر

المطلوب:

تصغير حجم الصورة الماخوذة بالسكنر حيث ان كل صورة يبلغ حجمها 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

مايو 13, 2021

18 دقائق مضت, Ahmed Sary said:

الشرط مش منطقي لأنك تطلب مجموع يساوى نص

بمعنى أنك بتقول للأكسس اجمع لي عدد السجلات اللي مجموعها كلمة كذا

والصحيح أن تستبدل

count

بــ

where

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

اريد اجراء استعلام مثل الذي بالصورة

مايو 13, 2021

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

مايو 13, 2021

السلام عليكم اخواني واستاذتنا الافاضل.

عيد فطر سعيد اعاده الله عليكم وعلينا .

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

تحياتي للجميع.

يونيو 5, 2020

34 دقائق مضت, Gamal.Saad said:
بعد اذن أستاذ أبوياسين :

الخطأ بسبب قيمة NULL لمربع النص X بالنموذج والحل:

اكتب بعد السطر الرابع (بعد تعيين قيمة Y ) :
x = y

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

يونيو 5, 2020

منذ ساعه, ابو ياسين المشولي said:

للاسف لم استطيع الدخول للموقع

حمل النموذج هنا لو سمحت

عفو استاذ لا يسمح الموقع ان ارفعة كون حجمة اكثر من 1 ميجا

هذا رابط اخر عسى ان تستطيع تحميلة مع فائق شكري مقدما

https://drive.google.com/file/d/1qeLaWW8gqQ-VKpEWgifKd4aEf8QjAH32/view?usp=sharing

يونيو 4, 2020

6 ساعات مضت, ابو ياسين المشولي said:

ارف النموذج اللي فيه الخطاء للتجربه

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

يونيو 3, 2020

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

اساتذتنا واخواننا في هذا المنتدى تحية لكم

ارجو مساعدتي في خطاء برمجي عند الضغط على زر السكنر تظهر لي هذه الجملة (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

مايو 28, 2020

11 ساعات مضت, أحمد الفلاحجى said:

اخى الفاضل عمر

مشاركه مع اخوانى واساتذتى الافاضل اشرف وابوفريد جزاهم الله خيرا 💐

وكما تم التوضيح لك منهم لايوجد لديك تكرار لماذا بارك الله فيك

انت تعتقد بان السجلات الخاصه بنائب العريف مكرره التكرار يشمل جميع الحقول الاساسيه والمرتبطه وطالما يوجد اختلاف فى رقم المستند وهما 4478 و 4458

غير اى رقم فيهم فى جدول Tbl_WheelUsers اجعلهم رقم واحد اى 4478 او 4458 وافتح الاستعلام ستجد بانه لايظهر معك الا سجلات فريده وغيره مكرره

جرب ووافنا بالنتيجه

بالتوفيق

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

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

تحياتي للجميع

مايو 28, 2020

19 دقائق مضت, Abu Farid said:

السلام عليكم

بعد اذن استاذ اشرف

تجد اختلاف في حقل الرتبة (رئيس عرفاء ، نائب عريف) و جميع سجلات منفردة و لايوجد تكرار

اشكرك اخي ولكن للتوضيح

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

مايو 28, 2020

5 ساعات مضت, اشرف said:

السلام عليكم اخي الفاضل omarAbdalrazaq

اين التكرار في الاستعلام المذكور

هل تقصد ما تم تدويره بالاحمر في الصورة

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

استاذنا العزيز اشرف مسحت العمودين الاخيرين وبقت نفس المشكلة

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

هل اذا لغيت الرتبة من دالة Horizontal تحل المشكلة التكرار؟

مايو 27, 2020

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

تحية طيبة الى اعضاء هذا المنتدى

عندي مشكلة واتمنى من استذتنا و اخواننا مساعدتي بها

المشكلة هي:

تكرار السجلات في الاستعلام المسمى Qry_ToAgnecy

ملاحظة:

ساعدني اساتذتنا في هذا الموقع سابقا في دمج حقول جدول فرعي في حقل واحد عن طريق دال Horizontal واستخدامة في هذ الاستعلام

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

الملف في الرابط ادناة

تحياتي للجميع

https://drive.google.com/open?id=1Wp0sPl-oa6USnQ1CGNCHUJbEqKBMiv4R

مايو 16, 2020

منذ ساعه, Gamal.Saad said:

عادي مفيش مشكلة بس التجميع هيكون : بدلاً من السيد/ أحمد ، العقيد/ وليد ، والوزير/ سيد

ستجد : 4/ أحمد ، 14/وليد ، 22/ سيد

لأن الجدول المشار إليه فيه أكواد الرتب أو اللقب وليس أسمائها

ولحل مؤقت للمشكلة يجب تعديل الدالة وعمل ربط مع جدول آخر به كود اللقب واسم اللقب ، كما بالمرفق

NewDB3.accdb 2.7 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 0 تنزيلات

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

مايو 16, 2020

6 ساعات مضت, Gamal.Saad said:

استنادا للدالة التي أوردها أستاذ أحمد الفلاحجى سابقاً

فانظر المرفق

NewDB2.accdb 2.71 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 1 تنزيلات

استاذ جمال بعد التحية والشكر على مشاركتك

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

[qryAllUser: Horizontal("Qry_ToAgency";"WheelName";"FullName";[WheelName

هل استطيع استبدال هذا الاستعلام بجدول اسماء السواق Tbl_WheelUsers

مايو 16, 2020

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

مايو 12, 2020

23 ساعات مضت, أحمد الفلاحجى said:
الشكر لله ثم لاخواننا واساتذتنا جزاهم الله خيرا

نعم يمكن عمل استعلام من استعلام

بالنسبه لطريقه الاستعلام qryAllUsers افتحه فى وضع التصميم هتلاقى الاستعلام ده مبنى على الاستعلام q

خدنا فيه حقل carName والحقل الاخر مستدعيين فيه الموديول Horizontal
qryAllUser: Horizontal("q";"carName";"UserName";[carName])
الموديول فيه 4 براميترات اسم الجدول q

اسم الحقل اللى هنجمع البيانات عليه carName

اسم الحقل المطلوب تجميع البيانات منه UserName

اسم الحقل لشرط التجميع carName

واعتذر لو فى تقصير

بالتوفيق اخى

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

وهل تتكرم علي وتضيف الحقل الذي يدمج الاسماء في برنامجي الرئيسي لان الملف الذي رفعتة هو مثال للتعلم وساكون شاكرا لك

اسم الاستعلام الذي اريد اضافة الحقل لة:

Qry_ToAgency

ولقد انشئت الموديل بالدالة Horizontal

رابط الملف للبرنامج الرئيسي

https://drive.google.com/open?id=1Wp0sPl-oa6USnQ1CGNCHUJbEqKBMiv4R

مايو 10, 2020

11 دقائق مضت, أحمد الفلاحجى said:

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

اخى الفاضل عمر @omarAbdalrazaq

لديك استعلام qryFirstUser للاول

ولديك استعلام للاخر qryLastUser

ولديك استعلام qrySumServiceAmount للجمع

ولديك استعلام q مبنى عليه استعلام qryAllUsers بيشغل المديول لاستدعاء جميع الاسماء بناء على السياره وجزاه الله خيرا صاحب المديول ولعل احد الاخوه الافاضل يساعد باضافه اللقب

له فلقد حاولت ولم اوفق معه الان وان شاء الله احد الاخوه واساتذتنا الافاضل يساعد

تقبل عذرى وتقصيرى

بالتوفيق اخى

Example.accdb 608 kB · 0 تنزيلات

شكرا استاذنا الفاضل احمد

هل يمكن اعلامي عن الطريقة التي عملت بها الاستعلام qryAllUsers؟

وهل يمكن عمل استعلام من استعلام اخر؟

مايو 10, 2020

السلام عليكم اخواني في هذا المنتدى الرائع

اود الاستفسار عن طريقة اضافة حقل في الاستعلام ياخذ معلوماتة من عدة سجلات او من سجل محدد في جدول فرعي

مثال

1- حقل في الاستعلام يجمع عمودين لجميع السجلات ويترك بينها حرف (و) مثال السيد محسن علي و السيد توفيق محمد و ....الخ

2-حقل في الاستعلام ياخد قيمتة من جمع اسماء عمودين العمود الاول والثاني في السجل الاول في جدول فرعي

3-حقل في الاستعلام ياخذ قيمتة من جمع اسماء عمودين العمود الاول والثاني في السجل الاخير في جدول فرعي

ملاحظة اود عدم تكرار السجات في الاستعلام.

مع العلم ان الجدول المعمول لة استعلام مرتبط مع الجدول الفرعي بعلاقة راس باطراف

وانا بامس لمعرفة انشاء مثل هذة الاستعلامات لحاجتي اليها في عملي وعمل التقارير او التصدير الى اكسيل

الملف في المرفقات

تحياتي للجميع

Example.accdb

مايو 8, 2020

1 دقيقه مضت, jjafferr said:

همممم

رجاء الرجوع الى البرنامج الاصل الذي اخذت الكود منه ، فهذه الدوال خاصة بذلك البرنامج ، ولا نعرف عنها شيء 🙂

لأني شايف دالة IsNoPath كذلك 🙄

جعفر

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

مايو 8, 2020

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

مايو 8, 2020

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

مايو 8, 2020

اسف على الصورة

وهذه نسخة من الكود

والمشكلة في دالة 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

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

الوسائط المتعددة

مشاركات المكتوبه بواسطه omarAbdalrazaq

Important Information