دروب مبرمج

نوفمبر 24, 2023

تفضل هذه الفكرة

image.png.77fcf8cedacecc11d810d23a2e1e3636.png

فكرة قوائم.zip

نوفمبر 24, 2023

النموذج

sub1

مرتبط بإستعلام جدولي لا يمكن التعديل على البيانات اثناء الاستعلام

اقترح بأن تستخدم جمل الاضافة لإضافة البيانات للجداول المرتبطة

sub2 و sub3

قم بتشغل اذونات التحرير

image.png.895974f124b78b2a0f63f93a0205b989.png

مرفق النموذج بعد التعديل

image.png.61714b23ce7d31689bc80ae3bb68c14b.png

up_ChangeSubForm.mdb

نوفمبر 17, 2023

انشئ نموذج جديد

وا ضف فيه مستعرض ويب

و في حدث عند النقر على قائمة الملفات ضع الكود التالي

Dim wb As Object
Set wb = WebBrowser0.Object        ' ضورة اضافة اسم عنصر التحكم لمستعرض الويب
Dim filelocation As String
filelocation = "C:\Users\File1.pdf"     ' ضع هنا اسم عنصر التحكم الذي يحتوي على اسم الملف لعرضه
wb.silent = True
With wb
    .navigate2 "about:blank"
    Do Until .ReadyState = 4
        DoEvents
    Loop
    .Document.Open
    .Document.write "<!doctype html><html><head><title>my title</title></head><body scroll=""auto"" style=""margin: 0px; padding: 0px;"">" & _
                        "<embed style='padding: 70px;' src=""" & filelocation & """  width=""50%"" height=""100%"" />" & _
                        "</body></html>"
    .Document.close
End With

نوفمبر 17, 2023

تفضل هذه المحاولة مع معلمي القديم @عمر ضاحى

1.accdb

نوفمبر 17, 2023

وتفضل هذه مشاركة مع الاخوان

DD409.accdb

نوفمبر 16, 2023

لإرسال رسالة واتس اب

اولاً / يجب تثبيت الواتس اب على الكبيوتر الخاص بك

ثانياً / هذه هي الشفرة الأساسية للإرسال

whatsapp://send?phone=" & "" & "&text=" & ""

ثالثاً انشئ موديول جديد و الصق فيه الشفرة التالية

Public Function SendMsg(Phon_Number As Variant, TexTMag As String)
Dim StrURL As Variant
Dim StrToNumber As Variant
Dim StrMsg As Variant

StrToNumber = Phon_Number
StrMsg = EncodeQP2(TexTMag)

StrURL = "whatsapp://send?phone=" & StrToNumber & "&text=" & StrMsg
CreateObject("WScript.Shell").Run StrURL, 1, False

Call StartTimer(3)
Call SendKeys("{ENTER}")

End Function

Public Function EncodeQP2(s As String) As String
    Dim i As Long
    Dim p1 As Long
    Dim p2 As Long
    Dim r As String
    Dim n As Long
    For i = 1 To Len(s)
        n = AscW(Mid(s, i, 1))
        If n < 128 Then
            r = r & "%" & Hex(n)
        ElseIf n < 2048 Then
            p1 = n \ 64
            r = r & "%" & Hex(p1 + 192)
            p2 = n Mod 64
            r = r & "%" & Hex(p2 + 128)
        Else
           
        End If
    Next i
    EncodeQP2 = r
End Function

Public Function StartTimer(NumberOfSeconds As Variant)
On Error Resume Next
Dim PauseTime, Start, Finish, TotalTime
    PauseTime = NumberOfSeconds
    Start = Timer
    Do While Timer < Start + PauseTime
        DoEvents
    Loop
    Finish = Timer
    TotalTime = Finish - Start
End Function

ثم في النموذج الخاص بك و في ازرار الارسال

Call SendMsg("966590000000", "السلام عليكم")

نوفمبر 16, 2023

استخدم دالة التجميع الشرطية DCount

مثال على ذلك

DCount("*","Table_Name","[ID]=" & [Forms]![Forms_Name]![TextBox1])

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

و يمكن بهذا الطريقة اضافة شرط كما يلي

If DCount("*", "Table_Name", "[ID]=" & [Forms]![Forms_Name]![TextBox1]) <> 0 Then

    If MsgBox("تم تسجيل الصنف من قبل" & _
    vbNewLine & "هل تريد اضافة الصنف مرة أخرى؟" _
    , vbQuestion + vbMsgBoxRight + vbYesNo, "تنبيه") = vbYes Then
        DoCmd.RunCommand acCmdSave
        MsgBox "تم اضافة صنف مشابه بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"
    Else
        DoCmd.RunCommand acCmdUndo
        MsgBox "تم التراجع عن الحفظ", vbCritical + vbMsgBoxRight, "تأكيد"
    End If
    
Else

    MsgBox "تم تسجيل الصنف بنجاح", vbInformation + vbMsgBoxRight, "تأكيد"

End If

يجب عليك الغاء المفاتيح الاساسية لكي تستطيع تنفيذ الشروط اعلاه

نوفمبر 16, 2023

يكون المعيار بهذا الشكل

WHERE Year([datein] Between Year(Now()) And Year(Now())-3

النتيجة

image.png.10697446c2bb2315887c3f6746070958.png

New Microsoft Access Database 1.accdb

نوفمبر 12, 2023

في 10‏/11‏/2023 at 21:19, kkhalifa1960 said:

استاذ @دروب مبرمج ممكن الكود لما تكون قاعدة البيانات بيوزر وباسوورد .

ما تحتاج كود لأن الكود يقوم بإنشاء نسخة مماثلة من النسخة الاساسية

يعني ما راح يفتح الملف و يقرأ الجداول

نوفمبر 10, 2023

تفضل هذا هو كود النسخة الاحتياطية بإختصار

لإنشاء نسخة احتياطة من القاعدة الحالية

Dim MyFile          As String
Dim DstFile         As String
Dim Syso            As Object
Dim GetType         As Variant

MyFile = CurrentProject.FullName  ' مسار القاعدة الحالية 
GetType = Right$(MyFile, Len(MyFile) - InStrRev(MyFile, "."))
DstFile = CurrentProject.Path & "\" & Format(Now, "dd-mm-yyyy-nss") & "." &  GetType  ' الاسم الجديد للنسخة الاحتياطية

DBEngine.Idle

Set Syso = CreateObject("Scripting.FileSystemObject")
Syso.copyfile MyFile, DstFile
Set Syso = Nothing

Name DstFile As DstFile & ".ptc"
DBEngine.CompactDatabase DstFile & ".ptc", DstFile
Kill DstFile & ".ptc"

لإنشاء نسخة احتياطية لقاعدة البيانات في حال ان القاعدة منفصلة عن الواجهة

Dim MyFile          As String
Dim DstFile         As String
Dim Syso            As Object
Dim GetType         As Variant

MyFile = CurrentProject.FullName  ' مسار قاعدة البيانات
GetType = Right$(MyFile, Len(MyFile) - InStrRev(MyFile, "."))
DstFile = CurrentProject.Path & "\" & Format(Now, "dd-mm-yyyy-hnss") & "." & GetType  ' الاسم الجديد للنسخة الاحتياطية

Set Syso = CreateObject("Scripting.FileSystemObject")
Syso.copyfile MyFile, DstFile
Set Syso = Nothing

أكتوبر 16, 2023

ضع هذا الكود في ازرار التقرير

If Not IsNull(TxtFrom) And IsNull(TxtTo) Then

        DoCmd.OpenReport "HR Data", acViewReport, _
        , "EmployeeHiring = #" & TxtFrom & "#"
        
ElseIf Not IsNull(TxtFrom) And Not IsNull(TxtTo) Then

        DoCmd.OpenReport "HR Data", acViewReport, _
        , "EmployeeHiring Between #" & TxtFrom & "#  And #" & TxtTo & "#"

ElseIf IsNull(TxtFrom) And IsNull(TxtTo) Then

        DoCmd.OpenReport "HR Data", acViewReport

End If

تفضل التعديل

Test (1).accdb

أكتوبر 12, 2023

هل هذا ما تريده ؟؟

image.png.0db629ba4c8c89003f79a2d805d679f7.png

AAA.accdb

أكتوبر 12, 2023

16 ساعات مضت, ابوخليل said:
تم تحقيق الفكرة مع مراعاة تغير نظام الحضور ( الشتوي / الصيفي)
 

خير الكلام ما قل و دل

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

أكتوبر 12, 2023

ماهي رسالة الخطأ التي تظهر لديك

أكتوبر 8, 2023

مع استعمال المكتبة

image.png.da659e1179662d095325dfce7a695a7a.png

انشى موديول جديد و الصق فيه الكود التالي

Option Compare Database
Option Explicit

Const WIA_FORMAT_JPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"

Public Function MyScan()
  Dim ComDialog As WIA.CommonDialog
  Dim DevMgr As WIA.DeviceManager
  Dim DevInfo As WIA.DeviceInfo
  Dim dev As WIA.Device
  Dim img As WIA.ImageFile
  Dim i As Integer
  Dim wiaScanner As WIA.Device

  Set ComDialog = New WIA.CommonDialog
  Set wiaScanner = ComDialog.ShowSelectDevice(WiaDeviceType.UnspecifiedDeviceType, False, True)

  Set DevMgr = New WIA.DeviceManager

  For i = 1 To DevMgr.DeviceInfos().Count
    If DevMgr.DeviceInfos(i).DeviceID = wiaScanner.DeviceID Then
      Set DevInfo = DevMgr.DeviceInfos(i)
    End If
  Next i

  Set dev = DevInfo.Connect

  Set img = dev.Items(1).Transfer(WIA_FORMAT_JPEG)

  img.SaveFile CurrentProject.Path & "\img.jpg"

  Set img = Nothing
  Set dev = Nothing
  Set DevInfo = Nothing
  Set DevMgr = Nothing
  Set ComDialog = Nothing


End Function

أكتوبر 7, 2023

تفضل التعديل

Database3.accdb

أكتوبر 5, 2023

تفضل هذا المثال

جربه عندك و اذا ضبط يصير نكمل الباقي

Scanner.accdb

أكتوبر 5, 2023

17 دقائق مضت, زياد الحسناوي said:

@Ahmed_J اساتذتي الاعزاء انا ايضا اعمل على برنامج الارشفة الالكترونية ولكنني توقفت عند اخذ الكتب عن طريق السكنر - حيث لم اجد طريقة لسحب الكتاب مع مرفقاته بالكامل عن طريق السكنر بضغطة واحد الا ورقة ورقة

ضبط سؤال جديد و ابشر بعزك طلبك بسيط

أكتوبر 4, 2023

تفضل هذا التعديل

Database521 (1).accdb

أكتوبر 2, 2023

تفضل التعديل

بحث.mdb

أكتوبر 2, 2023

تفضل

faozi.accdb

أكتوبر 2, 2023

6 دقائق مضت, زياد الحسناوي said:

بس سؤال كيف تم ذلك ؟

المشكلة كانت في العلاقات لم يكن هنالك علاقة بين الجداول

كل ما عملته هو انشاء علاقة

image.png.81d0a1ece76300aebfda3d0f190f6163.png

و انشاء فلتر من خلال الكود

Sub NewSearsh()
Dim varFilter As Variant
varFilter = Null
 
   If Not IsNull(KindBook) Then: varFilter = (varFilter) & "[KindBook] LIKE '*" & KindBook & "*'"
  
   If Not IsNull(Rbtbook) Then: varFilter = (varFilter + " AND ") & "[Rbtbook] LIKE '*" & Rbtbook & "*'"
   If Not IsNull(EntryInfo) Then: varFilter = (varFilter + " AND ") & "[EntryInfo] LIKE '*" & EntryInfo & "*'"
   If Not IsNull(NObook) Then: varFilter = (varFilter + " AND ") & "[NObook] = " & NObook
   If Not IsNull(DateBook) Then: varFilter = (varFilter + " AND ") & "[DateBook] LIKE '*" & DateBook & "*'"
   If Not IsNull(Adbook) Then: varFilter = (varFilter + " AND ") & "[Adbook] LIKE '*" & Adbook & "*'"
   If Not IsNull(SavePlace) Then: varFilter = (varFilter + " AND ") & "[SavePlace] LIKE '*" & SavePlace & "*'"
   If Not IsNull(EtC) Then: varFilter = (varFilter + " AND ") & "[EtC] LIKE '*" & EtC & "*'"
   If Not IsNull([NoW]) Then: varFilter = (varFilter + " AND ") & "[NoW] LIKE '*" & [NoW] & "*'"
   If Not IsNull(DateW) Then: varFilter = (varFilter + " AND ") & "[DateW] LIKE '*" & DateW & "*'"
   If Not IsNull(AljegehaW) Then: varFilter = (varFilter + " AND ") & "[AljegehaW] LIKE '*" & AljegehaW & "*'"
   SubSur = varFilter
End Sub

و اخذنا نسخة من الاستعلام لوضعها ضمن الكود و دمج الفلتر معها

أكتوبر 2, 2023

4 دقائق مضت, زياد الحسناوي said:

[Forms]![MultiSearchSadr].Form.RecordSource = df

RecordSource
يعني اعادة تعيين مصدر البيانات

مصدر البيانات الجديد ضمن الكود مع معايير البحث

أكتوبر 2, 2023

اذا هذا هو الحل تغيير العلاقات

بحث.mdb

أكتوبر 2, 2023

سؤالك مختص بالمجال المحاسبي

صمم الطريقة الي تحتاج يكون عليها الكشف و ابشر بعزك

و كذلك حدد الأعمدة الي راح تكون مصدر البيانات

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

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

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

Important Information