سامي الحداد

مايو 26, 2023

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

تفضل اخي الكريم

Private Sub cmdSearch_Click()
Dim strSearch As String
Static XC
Dim rs As Object
Set rs = Me.RecordsetClone
Me.أمر26.Visible = False
Me.أمر27.Visible = False
Me.أمر29.Visible = False
Me.أمر30.Visible = False
Me.أمر32.Visible = False
Me.أمر35.Visible = False

   If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then
          MsgBox "رجاء ادخل اسم للبحث عنه", vbOKOnly, "خطأ في البحث"
          Me![txtSearch].SetFocus
   Exit Sub
   End If
   strSearch = Me![txtSearch]
  
   With rs
  .FindNext "[emp_nam] like '*" & strSearch & "*'"
   
   If Not .emp_nam Like "*" & strSearch & "*" Then
          MsgBox "لا يوجد سجل بهذا الإسم :  " & strSearch, vbCritical, "غير موجود"
          Me.txtSearch = ""
          Me![txtSearch].SetFocus

   ElseIf .NoMatch Then
          MsgBox "آخر سجل في البحث عن :  " & strSearch, vbExclamation, "آخر سجل"
          Me.cmdSearch.Caption = "بحث"
          Me.txtSearch = ""
          Me![txtSearch].SetFocus
          Me.cmdSearch.ForeColor = RGB(0, 0, 255)
Me.أمر26.Visible = True
Me.أمر27.Visible = True
Me.أمر29.Visible = True
Me.أمر30.Visible = True
Me.أمر32.Visible = True
Me.أمر35.Visible = True

  DoCmd.GoToRecord , , acFirst
  rs.MoveFirst
  XC = 0
   Else
XC = XC + 1
   Me.Bookmark = .Bookmark
          If XC = 1 Then MsgBox "تم ايجاد اسم :  " & strSearch, vbInformation, "مبروك"
          Me.cmdSearch.Caption = "اكمال البحث"
          Me.cmdSearch.ForeColor = RGB(255, 0, 0)
   End If
   End With

rs.Close
Set rs = Nothing


End Sub

وهذا الملف بعد التعديل للعلم انا استخدم الاوفيس 2021 اذا لم يفتح معك الملف فقط انسخ الكود اعلاه وضعه تحت زر البحث ويجب عليك تغير مسميات الزر ونص البحث كما هو في الكود.

تحياتي

Database2023.accdb

مايو 22, 2023

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

الخطاء هنا

Exit_cmd_Select_Click:

    Call cmd_close_Click
    Exit Sub
    
err_cmd_Select_Click:

    If Err.Number = 1 Then
            
    Else

        MsgBox Err.Number & vbCrLf & Err.Description
        Resume Exit_cmd_Select_Click


وهذا الصحيح

Exit_cmd_Select2_Click:

    Call cmd_close_Click
    Exit Sub
    
err_cmd_Select2_Click:

    If Err.Number = 1 Then
            
    Else

        MsgBox Err.Number & vbCrLf & Err.Description
        Resume Exit_cmd_Select2_Click

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

shady master garage test1 24052023.rar

مارس 2, 2023

جرب التالي

Me.المبلغ_الاجمالي.DefaultValue = Nz(Form_الطالب.LenaT) - Nz(DSum("[دفع]", "نموذج الترحيل اليدوي", "[المعرف]=" & Form_الطالب.المعرف) - Nz(DSum("[mortaghday]", "نموذج الترحيل اليدوي", "[المعرف]=" & Form_الطالب.المعرف), 0))

واليك الملف ان شاءالله يكون هو المطلوب

11.accdb

7 دقائق مضت, Eng.Qassim said:

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

دوال المجال لاتعمل هكذا..

11.rar 141.53 kB · 0 downloads

المعذرة استاذ قاسم لم انتبه لردك كنت اكتب الرد وانشغلت بالرد على الهاتف

مارس 2, 2023

السلام عليكم

بالاضافة لما تقدم به جميع الاساتذة اليك الحل التالي على حسب فهمي لطلبك.

يرجى موافاتنا بالنتيجة.

Private Sub Supplier_NotInList(NewData As String, Response As Integer)

    Dim Db As DAO.Database
    Dim Rs As DAO.Recordset
    Dim Msg As String

    Msg = " " & NewData & "  المورد  " & Supplier & vbCr & vbCr & " غير موجود في القائمة " & vbCr & vbCr
    Msg = Msg & "هل تود إضافة هذا المورد ؟"
    If MsgBox(Msg, vbQuestion + vbYesNo) = vbNo Then
        Response = acDataErrContinue
        MsgBox "تم إلغاء عملية الإضافة", vbInformation, "تنبية"
        Supplier = ""
        Exit Sub
    End If

    On Error GoTo CancelAddNew
    Set Db = CurrentDb
    Set Rs = Db.OpenRecordset("Table1", dbOpenDynaset)

    Rs.AddNew
    Rs![Supplier] = NewData
    Rs.Update
    Response = acDataErrAdded

    Rs.Close
    Set Rs = Nothing
    Set Db = Nothing
    Exit Sub

CancelAddNew:
    
    Response = acDataErrContinue
    Set Rs = Nothing
    Set Db = Nothing
    Exit Sub
    

End Sub

الملف بعد التعديل

تحياتي

رسائل تنبية.accdb

فبراير 26, 2023

7 ساعات مضت, Radwan0 said:

وهو المطلوب

باركك الرحمن تعالى

الله ييارك فيك اخي الكريم.

فبراير 25, 2023

قد لا يحتوي متغير addPath على مسار ملف صالح. يجب عليك التحقق من أن قيمة addPath هي مسار ملف صالح وأن الملف موجود في هذا الموقع.

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

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

قد تكون هناك مشكلة في fSource.items.Item ((i)) مقارنة الاسم في حلقة For. يجب عليك التحقق من صحة المقارنة ومن أنه تم العثور على الملف الصحيح المراد إضافته.

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

فبراير 25, 2023

جرب هذه الاضافة ووافنا بالنتيجة.

Private Sub Form_Load()
    Me.Image1.SizeMode = fmPictureSizeClip
End Sub

فبراير 25, 2023

من بعد إذن الاستاذ @kkhalifa1960 جزاه الله خيرا

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

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

Sub AddToZip(ByVal zipArchivePath As String, ByVal addPath As String)
    Dim sh As Object
    Dim fSource As Object
    Dim fTarget As Object
    Dim iSource As Object
    Dim sourceItem As Object
    Dim i As Long
    Set sh = CreateObject("Shell.Application")
    Set fTarget = sh.Namespace((zipArchivePath))
    If fTarget Is Nothing Then
        createZipFile zipArchivePath
        Set fTarget = sh.Namespace((zipArchivePath))
        If fTarget Is Nothing Then
            MsgBox "فشل إنشاء ملف مضغوط", vbCritical
            Exit Sub
        End If
    End If
    Dim containingFolder As String
    Dim itemToZip As String
    containingFolder = Left(addPath, InStrRev(addPath, "\"))
    itemToZip = Mid(addPath, InStrRev(addPath, "\") + 1)
    Set fSource = sh.Namespace((containingFolder))
    For i = 0 To fSource.items.Count - 1
        If fSource.items.Item((i)).Name = itemToZip Then
            Set sourceItem = fSource.items.Item((i))
            Exit For
        End If
    Next i
    If sourceItem Is Nothing Then
        MsgBox "فشل العثور على ملف لإضافة ملف مضغوط  ", vbCritical
        Exit Sub
    End If
    On Error Resume Next
    fTarget.CopyHere sourceItem
    If Err.Number <> 0 Then
        MsgBox "فشل في إضافة ملف لضغطه", vbCritical
        Err.Clear
    End If
    On Error GoTo 0
End Sub

فبراير 25, 2023

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

Private Sub mail_DblClick(Cancel As Integer)
    Dim Msg As String
    
    If IsNull(Mail) Or Len(Mail) = 0 Then
        MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني "
        Exit Sub
    End If
    
    Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _
          " hey " & namecus & "<br>" & _
          "</div>"
    
    Dim O As Outlook.Application
    Dim M As Outlook.MailItem
  
    Set O = New Outlook.Application
    Set M = O.CreateItem(olMailItem)
  
    With M
        .BodyFormat = olFormatHTML
        .HTMLBody = Msg
        '.Body = txt - if you see olformatplain
        .To = Mail
        '.CC="khate9191@gmail.com;khateb91@outlook.com"
        '.BCC="hateeb991@gmail.com"
        .Subject = " new mail " & Now()
        .Display
       '.send
    End With
    
    Set M = Nothing
    Set O = Nothing
End Sub

تحياتي

فبراير 25, 2023

1 ساعه مضت, kkhalifa1960 said:

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

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

أحسنت وبارك الله فيك اخي @kkhalifa1960

فبراير 25, 2023

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

تفضل اخي جرب الكود واعلمني بالنتيجة لانني لا استخدم الاوتلوك.

Private Sub mail_DblClick(Cancel As Integer)
 Dim Msg As String
    
    If Len(Mail) = 0 Then
        MsgBox "حقل البريد الإلكتروني فارغ. الرجاء إدخال عنوان البريد الإلكتروني "
        Exit Sub
    End If
    
    Msg = "<div style='direction:rtl; font-family:Consolas, Courier;'>" & _
          " hey " & namecus & "<br>" & _
          "</div>"
    
    Dim O As Outlook.Application
    Dim M As Outlook.MailItem
  
    Set O = New Outlook.Application
    Set M = O.CreateItem(olMailItem)
  
    With M
        .BodyFormat = olFormatHTML
        .HTMLBody = Msg
        '.Body = txt - if you see olformatplain
        .To = Mail
        '.CC="khate9191@gmail.com;khateb91@outlook.com"
        '.BCC="hateeb991@gmail.com"
        .Subject = " new mail " & Now()
        .Display
       '.send
    End With
    
    Set M = Nothing
    Set O = Nothing
End Sub

تحياتي

فبراير 24, 2023

السلام عليكم

بالاضافة لما تفضل بة اساتذتي الكرام جرب تغير هذه الاسطر . و وافنا بالنتيجة

Dim strInvoiceID As String

Set rsFatora = db.OpenRecordset("SELECT * FROM tblFatora WHERE FatoraId <> '" & strInvoiceID & "'")
Set rsHaraka = db.OpenRecordset("SELECT * FROM tblHaraka WHERE Fatora_id <> '" & strInvoiceID & "'")

بالتوفيق

يناير 28, 2023

نعم اخي @محمد احمد لطفى

تحتاج الى مكتبة Microsoft Excel XX.X Object Library

xx.x = رقم نسحة الاوفيس لديك 12.0 او 14.0 او 15.0 الخ..

تحياتي

يناير 28, 2023

اخي العزيز @العبيدي رعد

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

العفو الخلط بالكيبورد اقصد جدول user&pass ايضا ... هل احذفهما من البرنامج ؟
وسؤالي كيف أحدد الصلاحيات ابتداءا ؟ وعند دخولي للبرنامج عن طريق الفورم كيف سيتعرف عن صاحب الصلاحيات لنموذج الادمن ؟

الجدول user&pass كان في ملفك من الاساس

تحديد الصلاحيات يتم عن طريق دخول الادمن من نموذج تسجيل الدخول او الجدول ثم اعطاء كل الصلاحيات للنماذج وتفعيل كل الخانات ما عدا Button Disable. ضروري ان يكون الزر غير مفعل

وبعدها تستطيع ان تكمل مع باقي المستخدمين واعطاء كل مستخدم الصلاحية المطلوبة. وإغلاق الازرار

منذ ساعه, العبيدي رعد said:

@سامي الحداد السلام عليكم

أخي العزيز .. عرفت الادمن من جدول الصلاحيات ولكن يظهر لي خطأ في الكود عندما اريد الدخول الى الصفحة الرئيسية main

وأرفق صور توضيحية للجدول والخطأ الذي يحث في حدث onopen للنموذج

بالنسبة لهذا الخطاء هو انه زر الامر Command0 غير موجود في هذا القورم .

وهناك ايضا خطاء انه تم تفعيل زر Button Disable لان الشخص ابو ايمان له كل الصلاحيات إذن يجب إلغاء هذا الزر وعدم تفعيله اذا كان الادمن.

سارفق لك نفس ملفك الاول والذي عملت عليه واعطيت سامي صلاحية الادمن وكلمة المرور 555 انظرا جيدا كيف تم العمل واكمل .

واي استفسار بخدمتكم . ربما أتاخر في الاجابة بسببت فرق التوقيت

تحياتي

صلاحيات.accdb

يناير 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

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

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

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

Important Information