سامي الحداد

يناير 28, 2023

حياك الله اخي الدكتور محمد

اليك ثلاثة ملفات باكواد مختلفة وجميعها تعمل بشكل صحيح مع الويندوز 10 والاوفيس 2019 .

وكما ذكرت سابقا لن استطع التطبيق على الويندوز 7 والاوفس 2010 لانني لا املكهم.

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

وكنت أتمنى من الاخ @tamer.murad صاحب الموضوع ان يبدي رأيه أيضا.

تحياتي لشخصكم الكريم

1275940712_AllVer.MediaSoft.rar

يناير 27, 2023

8 ساعات مضت, سامي الحداد said:

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

8 ساعات مضت, سامي الحداد said:

Dim formsDictionary As New Scripting.Dictionary
    formsDictionary.ADD ChrW(&H62A), "frmCompany"
    formsDictionary.ADD ChrW(&H622), "frmSystemUserData"
    formsDictionary.ADD ChrW(&H643), "frmPassword"
    formsDictionary.ADD ChrW(&H62C), "frmDeveloper"

4 ساعات مضت, الحلبي said:

اعانك الله علينا ودام عليك نعمة مساعدة الاخرين

بخدمتكم استاذي الكريم

تحياتي

يناير 27, 2023

تفضل اخي

شوف التعديل هل هو المطلوب؟

Option Compare Database
Option Explicit
Dim strSQL As String
Dim rs As DAO.Recordset
Dim PreviousSearchText As String
Private Sub CmdClear_Click()
Me.TEXT_CHERCHE = ""
Me.Query_no_subform.Form.Filter = ""
Me.Query_no_subform.Form.FilterOn = False
Me.Query_no_subform.Form.Requery
End Sub
'1 OK
Private Sub TEXT_CHERCHE_Change()
    If Me.TEXT_CHERCHE.Text = "" Then
       Me.Query_no_subform.Form.Filter = ""
       Me.Query_no_subform.Form.FilterOn = False
    Else
        Dim strSQL As String
        strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34)
        Me.Query_no_subform.Form.Filter = strSQL
        Me.Query_no_subform.Form.FilterOn = True
        
        If Me.Query_no_subform.Form.Recordset.RecordCount = 0 Then
           MsgBox "لم يتم العثور على سجلات للنص المدخل", vbInformation, "تنبيه"
          End If
    End If
End Sub

  
  Private Sub cmdPrintPreview_Click()
    Me.TEXT_CHERCHE.SetFocus

    strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34)
    ' Open the report in print preview mode
    DoCmd.OpenReport "MyReport", acViewPreview, , strSQL
End Sub

Private Sub TEXT_CHERCHE_KeyDown(KeyCode As Integer, Shift As Integer)
  If KeyCode = 27 Then
    Me.TEXT_CHERCHE.Text = ""
    Me.Query_no_subform.Form.Filter = ""
    Me.Query_no_subform.Form.FilterOn = False

  End If
End Sub

تحياتي

my PR.accdb

يناير 27, 2023

بالاضافة لما تفضل به الاستاذ @kkhalifa1960 جزاه الله خيرا

اليك مشاركتي

Option Compare Database
Option Explicit
Dim strSQL As String
Dim rs As DAO.Recordset
Private Sub CmdClear_Click()
Me.TEXT_CHERCHE = ""
Me.Query_no_subform.Form.Filter = ""
Me.Query_no_subform.Form.FilterOn = False

End Sub
Private Sub TEXT_CHERCHE_Change()
    

strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34)
    Me.Query_no_subform.Form.Filter = strSQL
    Me.Query_no_subform.Form.FilterOn = True

    Set rs = Me.Query_no_subform.Form.Recordset
    If (rs.RecordCount <> 0) Then
    rs.MoveFirst
    Do Until rs.EOF
        rs.Edit
        rs![oui/non] = True ' change "chkBoxFieldName" with the actual name of your checkbox field
        rs![date_à_regler] = Date ' change "dateFieldName" with the actual name of your date field
        rs.Update
        rs.MoveNext
    Loop
Else
        MsgBox "السجل المطلوب تم التحقق منه سابقا بتاريخ "
End If

End Sub

Private Sub cmdPrintPreview_Click()
    Me.TEXT_CHERCHE.SetFocus

    strSQL = "numéro_coud LIKE " & Chr(34) & Me.TEXT_CHERCHE.Text & "*" & Chr(34)
    ' Open the report in print preview mode
    DoCmd.OpenReport "MyReport", acViewPreview, , strSQL
End Sub

وهذا ملفك بعد التعديل. هل هو المطلوب؟

بالتوفيق

my PR.accdb

يناير 27, 2023

21 ساعات مضت, الحلبي said:

قاعدة البيانات ترفض تماما اضافة اى شئ داخل محرر الاكواد ـ لا اعرف السبب

هل ممكن ان ترفق ملفك حتى نرى اين المشكلة ؟

وجرب هذا التعديل

Private Sub Form_Load()
    Dim OldLong As Long
    Dim nodX As Node
    Set nodX = TreeView1.Nodes.ADD(, , "R", "أعدادات النظام", 3)
    Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C1", "بيانات الشركة", 2)
    Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C2", "بيانات مستخدمي النظام", 5)
    Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C3", "كلمات المرور", 1)
    Set nodX = TreeView1.Nodes.ADD("R", tvwChild, "C4", "بيانات المطورين", 4)
    nodX.EnsureVisible
    OldLong = GetWindowLong(TreeView1.hwnd, GWL_EXSTYLE)
    SetWindowLong TreeView1.hwnd, GWL_EXSTYLE, OldLong Or WS_EX_LAYOUTRTL
    InvalidateRect hwnd, 0, False
    
    Dim formsDictionary As New Scripting.Dictionary
    formsDictionary.ADD ChrW(&H62A), "frmCompany"
    formsDictionary.ADD ChrW(&H622), "frmSystemUserData"
    formsDictionary.ADD ChrW(&H643), "frmPassword"
    formsDictionary.ADD ChrW(&H62C), "frmDeveloper"

End Sub
Private Sub TreeView1_Click()
   
    Dim strFormName As String
    Dim formsDictionary As New Scripting.Dictionary
    formsDictionary.ADD "بيانات الشركة", "frmCompany"
    formsDictionary.ADD "بيانات مستخدمي النظام", "frmSystemUserData"
    formsDictionary.ADD "كلمات المرور", "frmPassword"
    formsDictionary.ADD "بيانات المطورين", "frmDeveloper"
    strFormName = TreeView1.SelectedItem.Text
    If formsDictionary.Exists(strFormName) Then
        DoCmd.OpenForm formsDictionary(strFormName)
    Else
        MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه"
    End If


End Sub

21 ساعات مضت, الحلبي said:

جزاك الله كل خير ـ وبارك الله فيك وفى علمك ـ وزادك الله من رزقه وعلمه

ولك بمثل ما دعوت أخي الدكتور محمد

تحياتي

يناير 27, 2023

السلام عليكم

وهذه مشاركتي مع الاساتذة جزاهم الله كل خير

=IIf(Len("" & [Strdate] & [Enddate])=0,"No Date",[zofdate])

fmmm3.accdb

يناير 26, 2023

7 دقائق مضت, العبيدي رعد said:

السلام عليكم

ماهو دور الجدولين tblsecurtytype

و عسثق&حشسس

هاي ما اعرفها (و عسثق&حشسس)

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

يناير 26, 2023

2 ساعات مضت, العبيدي رعد said:

هذا حدث واحد يوضع في كل فورم ندخل عليه أم في الفورم الرئيسي main

نعم اخوي رعد يضع في كل فورم هذا الكود.

Private Sub Form_Open(Cancel As Integer)
Call UserPermission(Me, GetUserLoginID())
End Sub

وإذا كان الفورم فيه ازرار تريدها ان تكون غير مفعلة تضع باقي الكود فيصبح كالاتي.

Private Sub Form_Open(Cancel As Integer)
Call UserPermission(Me, GetUserLoginID())

If TempVars!IsFormOpened = 1 Then
    Exit Sub
Else

    Call DisableButton(Me, GetUserLoginID, Me.cmdSetPermission, هنا تضع اسم الزر مثلا Me.Addnew) 
End If
End Sub

حياك الله

28 دقائق مضت, العبيدي رعد said:

السلام عليكم

استاذ سامي .... أريد الخطوة الاولى وهي تعريف المسؤول الرئيسي هل ابدأ من الجدول
فأنا المسؤول عن النظام لكني لاأريد امكانية ادخال سندات فمهمتي هي مراقبة من يدخل البيانات

تستطيع ان تبدا من الجدول نعم فقط لك كمسؤول . ومن ثم عليك إغلاق كل الابواب وعدم السماح بالدخول من الخلف.

يناير 26, 2023

اخي واستاذي الحبيب @الحلبي

من المحتمل أن تكون المشكلة التي تواجهها متعلقة بالطريقة التي يتم بها التعامل مع النص العربي في الإصدار الأقدم من Office و Windows. في Office 2010 و Windows 7 ، يكون ترميز الأحرف الافتراضي للنص هو ANSI ، والذي قد لا يدعم جميع أحرف Unicode ، بما في ذلك الأحرف العربية. وللتغلب على هذه المشكلة هناك طريقتين الحل الاول هو تغيير ترميز الأحرف الافتراضيه للملفات النصية ، وسوف نغير ترميز الأحرف الافتراضي إلى UTF-8

ساضع الكود هنا للطريقة الاولى جرب ووافيني بالنتيجة.

Option Explicit

#If Win64 Then
    Private Declare PtrSafe Function SetFileApisToOEM Lib "kernel32" () As Long
    Private Declare PtrSafe Function SetFileApisToANSI Lib "kernel32" () As Long
#Else
    Private Declare Function SetFileApisToOEM Lib "kernel32" () As Long
    Private Declare Function SetFileApisToANSI Lib "kernel32" () As Long
#End If

Private Sub TreeView1_Click()
    Dim strFormName As String
    Dim formsDictionary As New Scripting.Dictionary
    
    SetFileApisToANSI
    System.PrivateProfileString("", "", "")
    System.PrivateProfileString("", "", "")
    SetFileApisToOEM
    System.PrivateProfileString("", "", "")
    System.PrivateProfileString("", "", "")

    formsDictionary.Add "بيانات الشركة", "frmCompany"
    formsDictionary.Add "بيانات مستخدمي النظام", "frmSystemUserData"
    formsDictionary.Add "كلمات المرور", "frmPassword"
    formsDictionary.Add "بيانات المطورين", "frmDeveloper"

      strFormName = TreeView1.SelectedItem.Text
      If formsDictionary.Exists(strFormName) Then
      DoCmd.OpenForm formsDictionary(strFormName)
Else
      MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه"
End If
End Sub

عذرا اخي الدكتور محمد لم اجرب الكود لانني لا املك الويندوز 7 والاوفيس 2010 . بانتظار تجربتك.

تحياتي

يناير 25, 2023

1 ساعه مضت, محمد احمد لطفى said:

أستاذى @سامي الحداد
جزاك الله خيراً
حضرتك حذفت السطر الاول يدوى ولا من خلال اكسيس أرجو الافادة

سؤال ممكن اسماء الحقول تبدأ من السطر التانى فى اكسيس

تم حذف السطر الاول من ملف الاكسس بواسطة كود من الاكسس وهذا هو الكود.

Sub DeleteFirstRow()
    Dim xlApp As Excel.Application
    Set xlApp = New Excel.Application

    Dim xlWorkbook As Excel.Workbook
    Set xlWorkbook = xlApp.Workbooks.Open("C:\xxxxx\0125.xls")غير مسار الملف   
											
    xlWorkbook.Sheets(1).Activate

    Dim firstRow As Excel.Range
    Set firstRow = xlApp.ActiveSheet.Range("A1:IV1")

    firstRow.Delete

    xlWorkbook.Save
    xlWorkbook.Close

    xlApp.Quit
End Sub

بالتوفيق

يناير 25, 2023

بالاضافة لما تفضل به الاساتذة اليك مشاركتي

Sub CopyTableStructure()
   
      If Not TableExists("tblOld") Then
        MsgBox "Table 'TblOld' does not exist in the current database."
        Exit Sub
End If

    Dim strPath As String
    strPath = CurrentProject.FullName
    DoCmd.TransferDatabase acImport, "Microsoft Access", strPath, acTable, "tblOld", "TblNew", True


End Sub

Function TableExists(tblName As String) As Boolean
    TableExists = (CurrentDb.TableDefs(tblName).Name = tblName)
End Function

testdate4.mdb

يناير 25, 2023

منذ ساعه, محمد احمد لطفى said:

أستاذى @ابو البشر
هذا المرفق

وجزاك الله خيراً

0125.xls 32 kB · 2 downloads

مثل ما تفضل به الاستاذ @ابو البشر والكود له جزاه الله خيرا .

انا فقط حذفت السطر الاول من الاكسل حسب طلبك جرب ووافينا بالنتيجة .

testdate4.rar

يناير 25, 2023

منذ ساعه, tamer.murad said:

السلام عليكم

كل ماريده هو :

Treeview يكون عربي

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

نعم أخي الكريم تفضل

Private Sub TreeView1_Click()
   
    Dim strFormName As String
    Dim formsDictionary As New Scripting.Dictionary
    formsDictionary.ADD "بيانات الشركة", "frmCompany"
    formsDictionary.ADD "بيانات مستخدمي النظام", "frmSystemUserData"
    formsDictionary.ADD "كلمات المرور", "frmPassword"
    formsDictionary.ADD "بيانات المطورين", "frmDeveloper"
    strFormName = TreeView1.SelectedItem.Text
    If formsDictionary.Exists(strFormName) Then
        DoCmd.OpenForm formsDictionary(strFormName)
    Else
        MsgBox "عذرا هذا النموذج غير موجود", vbExclamation, "تنبيه"
    End If
End Sub

واليك الملف بعد التعديل .

المكتبات المطلوبة انظر الصورة

بالتوفيق

MediaSoft 2.rar

يناير 25, 2023

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

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

Private Sub TreeView1_Click()
    Dim strFormName As String
    strFormName = TreeView1.SelectedItem.Text
    DoCmd.OpenForm strFormName
End Sub

واليك الملف بعد التعديل لقد اضفت لك كل النماذج . هل هو المطلوب؟

MediaSoft 1.rar

يناير 23, 2023

المعذرة اخي الكريم نسيت ان اضيف هذا وهو اسم الزر المراد اخفاءه في الكود.

Private Sub Form_Open(Cancel As Integer)
Call UserPermission(Me, GetUserLoginID())

If TempVars!IsFormOpened = 1 Then
    Exit Sub
Else

    Call DisableButton(Me, GetUserLoginID, Me.cmdSetPermission, Me. اسم الزر المراد اخفاءه) 
End If
End Sub

يناير 23, 2023

وعليكم السلام أخي الكريم

بالنسبة ل All Forms فهي للادمن فقط. اما بالنسبة لزر Disable Button فهو لاخفاء زر معين في نموذج أو من القائمة الرئيسية مثلا : في النموذج لديك مستخدم يستطيع ان يضيف ولكن لا يستطيع ان يحذف وهذا النموذج فيه اضافة وحذف هنا يأتي زر الاخفاء بحيث هذا المستخدم لا يستطيع ان يحذف, فقط يستطيع الاضافة. لهذا اضفت هذه الخاصية لتعطيل زر معين. أدخل باسم المستخدم B على ما اعتقد سترى ان زر صفحة الادمن غير مفعلة. وهناك بعض الازرار مفعلة ولكن ليس لدية الصلاحية لفتح النموذج. واليك كيفية عمل ذلك..

استدعاء وظيفة User Permission في كل نموذج ضمن الحدث Form_Open

Private Sub Form_Open(Cancel As Integer)
Call UserPermission(Me, GetUserLoginID())
End Sub

--------------------------------------------------------------------------
إذا كان لديك بعض الأزرار لتعطيلها للمستخدم العادي ، فاستدع الوظيفة "UserPermission" و "DisableButton" ضمن حدث Form_Open

Private Sub Form_Open(Cancel As Integer)
Call UserPermission(Me, GetUserLoginID())

If TempVars!IsFormOpened = 1 Then
Exit Sub
Else

Call DisableButton(Me, GetUserLoginID, Me.cmdSetPermission)
End If
End Sub

يجب إضافة كل النماذج في جدول tbl_Forms ضروري.

اتمنى ان اكون قد وفقت في الشرح وبخدمتكم.

تحياتي

يناير 21, 2023

أخي الكريم @العبيدي رعد

الملف الذي ارفقته لك فيه كل ما طلبت يمكن جنابكم ما فتحتم الملف.

سجل الدخول بإسم Sami وكلمة المرور 555 ادخل على صلاحيات المستخدمين واختار المستخدم من القائمة وسترى النماذج والتي بامكانك تغيرها على حسب النماذج التي في برنامجك ومنها تستطيع ان تعطي الصلاحيات لكل نموذج . إذا الموضوع صعب عليك ارفق برنامجك هنا وساعمل لك الصلاحيات المطلوبة لكل مستخدم .. الموضع سهل جدا وما فيه اي تعقيد.

غير المستخدم سامي واجعله الادمن وغير اسماء المستخدمين واعطيهم الصلاحيات الطلوبه.

بانتظار ردك.

تحياتي

يناير 20, 2023

حياك الله اخوي @طاهر الوليدي

نعم في الملف الاخير العملاء4 توجد هذه الخاصية تستطيع البحث في حقل الاسم فقط وذلك بازالة الاختيار من بافي الخانات , لقد ثبتت حقل الاسم في البحث في هذا المثال فقط لانة ممكن ان تتشابة البيانات مثل رقم العمارة او رقم الشقة مثلا لذلك وضعت حقل الاسم ثابت في البحث هذا فقط في هذا المثال. جرب الملف اضغط على إلغاء التحديد ستبقى خانة الاسم فقط هي المتوفرة للبحث حاول ان تبحث عن اي شيء غير الاسم لن تحصل على اي نتيجة لان البحث والتركيز فقط على حقل الاسم . ارجو ان اكون قد وفقت في الاجابة على سؤالك واذا كان لديك اي استفسار اخر فانا بخدمتكم .

تحياتي

يناير 19, 2023

السلام عليكم

مشاركة مع الاستاذ @kkhalifa1960 جزاه الله خيرا

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

بالتوفيق

صلاحيات.accdb

يناير 19, 2023

السلام عليكم أخي @سيد رجب

أسف جدا على التأخير لانشغالي بالعمل

اليك الملف وفيه طريقة البحث بأكثر من معيار كما وعدتك وايضا عند إضافة عميل جديد أذا كان الاسم موجود سيتم إلغاء الاضافة وسيتم نقللك للسجل المطلوب, وبالنسبة لمربعات التحرير عند إضافة سجل جديد تتم عملية التصفية فقط للاضافة وليس للبحث ولا تنسى عند إضافة سجل جديد يجب ان تضغط على زر الحفط حتى يتم تحديث البيانات في الجدول .

تفيل تحياتي وبالتوفيق

العملاء4 .accdb

يناير 16, 2023

الملف المرفق العملاء 2 هو طلبك

اما الصورة فهذا الملف لم ارفقة هنا مجرد توضيح فقط لعمل تغير طريقة عمل البحث طبعا هذا مجرد رأي .

يناير 16, 2023

السلام عليكم

تفضل أخي الكريم تم التعديل على ملفك في المشاركة الاولى .

هل هو المطلوب وافنا بالنتيجة.

انا لي رأي اخر في عملية البحث انظر للصوره ان احببت سارفق لك الملف .

بالتوفيق

العملاء 2.accdb

يناير 13, 2023

اخي العزيز ابو جودي

إنّا لله وإنّا إليه راجعون رحمه الله وآجرك. حسن الله عزاكم فيه، وعظَّم لكم الأجور، وألهمكم التسليم للمقدور، نقول جميعاً كما قال الصابرون إنّا لله وإنّا إليه راجعون.٠

يناير 8, 2023

في 7‏/1‏/2023 at 16:38, حمدى الظابط said:

Dim IEE As Object
    Dim SQL As String
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String
    Dim Mytoname As String
    Dim stname1 As String

    Dim rs As DAO.Recordset
     Set rs = CurrentDb.OpenRecordset("email")
        rs.MoveLast: rs.MoveFirst
 Dim IE As Object

    DoCmd.RunCommand acCmdSaveRecord
    If Nz(DCount("SelectRow", "email", "SelectRow = 'R'"), 0) = 0 Then
    MsgBox "يجب اختيار المرسل اليه اولا", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
    End If
    Me.myname.SetFocus
     If IsNull(Me.msg) Then
    MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
 End If
 If IsNull([email1].Form![phone_number]) Then
    MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
 End If
    DoCmd.OpenForm "email4", acNormal
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "&  app_sent =0"
Pause 3
SendKeys "{TAB}"
Call SendKeys("~", True)

    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)
         If rs.Fields("SelectRow") = "R" Then
           Mytoname = rs.Fields(0)
           stname1 = rs.Fields("toname")

Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text="

Pause 3

Set IE = Nothing
Set IEE = Nothing

Dim objClipboard As Object
Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClipboard.SetText (MyFile)
objClipboard.PutInClipboard
Pause 5
SendKeys "+{TAB}"
Call SendKeys("{Enter}", True)
Pause 2
Call SendKeys("{Enter}", True)
Pause 5
Langauge ELanguage.en
Pause 5
Call SendKeys("^v", True)
Call SendKeys("{Enter}", True)
Pause 5
Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClipboard.SetText (Me.msg)
objClipboard.PutInClipboard
Pause 1
Call SendKeys("^v", True)
Pause 5
Call SendKeys("{Enter}", True)
Pause 1

                DoCmd.SetWarnings False
                        DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname
                        DoCmd.Requery
                DoCmd.SetWarnings True
        
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"

         End If
            rs.MoveNext
        Wend
    End If
    rs.Close
    Set rs = Nothing    
MsgBox "تم الارسال"
End Sub

أخي حمدي

جرب الكود الان سبب تكرار الارسال هو هذه الاسطر

Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || " & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "&  app_sent =0"
Pause 3
SendKeys "{TAB}"
Call SendKeys("~", True)

اليك الكود كاملا بعد التعديل

Dim IEE As Object
    Dim SQL As String
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String
    Dim Mytoname As String
    Dim stname1 As String

    Dim rs As DAO.Recordset
     Set rs = CurrentDb.OpenRecordset("email")
        rs.MoveLast: rs.MoveFirst
 Dim IE As Object

    DoCmd.RunCommand acCmdSaveRecord
    If Nz(DCount("SelectRow", "email", "SelectRow = 'R'"), 0) = 0 Then
    MsgBox "يجب اختيار المرسل اليه اولا", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
    End If
    Me.myname.SetFocus
     If IsNull(Me.msg) Then
    MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
 End If
 If IsNull([email1].Form![phone_number]) Then
    MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
 End If
    DoCmd.OpenForm "email4", acNormal
'Set IE = CreateObject("InternetExplorer.Application")
'IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub & "*" & "&  app_sent =0"
'Pause 3
'SendKeys "{TAB}"
'Call SendKeys("~", True)

    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)
         If rs.Fields("SelectRow") = "R" Then
           Mytoname = rs.Fields(0)
           stname1 = rs.Fields("toname")

Dim strMSG As String
strMSG = " || *" & Me.myname.Value & "*" & " || *" & Me.msg.Value & "*" & " || *" & Me.attach.Value & "* || " & "المرسل : *" & Me.sub
strMSG = ReplaceLineBreaks(strMSG)
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & strMSG & "*" & "&  app_sent =0"
Pause 3

Set IE = Nothing
Set IEE = Nothing

Dim objClipboard As Object
Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClipboard.SetText (MyFile)
objClipboard.PutInClipboard
Pause 5
SendKeys "+{TAB}"
Call SendKeys("{Enter}", True)
Pause 2
Call SendKeys("{Enter}", True)
Pause 5
Langauge ELanguage.en
Pause 5
Call SendKeys("^v", True)
Call SendKeys("{Enter}", True)
Pause 5
Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClipboard.SetText ReplaceLineBreaks(Me.msg)
objClipboard.PutInClipboard
Pause 1
Call SendKeys("^v", True)
Pause 5
Call SendKeys("{Enter}", True)
Pause 1

                DoCmd.SetWarnings False
                DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname
                DoCmd.SetWarnings True
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"

         End If
            rs.MoveNext
        Wend
    End If
    rs.Close
    Set rs = Nothing
    
MsgBox "تم الارسال"
End Sub

' =================================(وهذه دالة لجعل الواتسأب يقبل السطور الجديدة في النص المرسل)
Function ReplaceLineBreaks(text As String) As String
    ReplaceLineBreaks = Replace(text, vbCrLf, " %0a ")
    ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(10), " %0a ")
    ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(13), " %0a ")
End Function

المعذرة أخي لم أجرب الكود على البرنامج وذلك لانشغالي . جرب الكود هذا وان شاءالله عندما يسمح الوقت ساكون معكم .

بالتوفيق

يناير 6, 2023

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

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

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

المستخدمين كالتالي

الاسم: علي كلمة المرور 123

الاسم: رضوان كلمة المرور 123

الاسم: سامي كلمة المرور 555

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

بالتوفيق

ساغيب عن المنتدى لبضعة ايام بسبب السفر والعمل.

PasswordLogin_RC4_v5.4.accdb

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

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

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

Important Information