دروب مبرمج

    Dim conn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim strConnString As String
        strConnString = "Provider=SQLOLEDB;Data Source=Server_Name;Persist Security Info=True;User ID=Your_UserName;Password=Your_Password;"
        
        Set conn = New ADODB.Connection
        conn.Open strConnString

        Set rs = conn.Execute("SELECT * FROM TabolName")
                
           If Not rs.BOF And Not rs.EOF Then
                rs.MoveFirst
                While (Not rs.EOF)
                 TextBox1= rs.Fields(0).Value
                    rs.MoveNext
                Wend
            End If
            rs.Close
            Set rs = Nothing

مع اضافة المكتبة

ADODB Connection - PK: An Excel Expert

ديسمبر 3, 2024

اخي العزيز

image.png.ce4be2e39793994835d8bddd9b737cfd.png

image.png.fb44198eb52d3d803695293d37cef3e0.png

تفضل التعديل

JO.accdb

ديسمبر 3, 2024

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

سوف نقوم بالإعلان عن ثلاث متغييرات لغرض تخزين اسم المجلد و مسار الملف

Dim strPath As String, fileName As String, sFile As String

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

strPath = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=" & MyList.Column(0))

و هنا سنقوم بإستخراج اسم الملف من المسار المخزن في قاعدة البيانات

fileName = Right$(strPath, Len(strPath) - InStrRev(strPath, "\"))

و الآن نقوم بجمع النتائج اعلاه في مسار واحد

sFile = CurrentProject.Path & "\MY_Files\" & P_NAMES.Column(1) & "\" & fileName

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

[Forms]![Attacheds]![Show_Files]![MY_PDF].ControlSource = "=""" & sFile & """"

و النتيجة

image.png.fe9b1cc35941ac62e3111325eaba242d.png

تفضل التعديل

LAB2.zip

نوفمبر 25, 2024

تفضل هذا التعديل البسيط

Database4.zip

نوفمبر 24, 2024

تفضل هذا التعديل البسيط

البحث وتعديل درجات8.zip

نوفمبر 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

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

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

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

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

Important Information