اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

د.كاف يار

الخبراء
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    1,681

  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    60

 نوع المحتوي 

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

    تحديث برنامج تم انشاؤه بالاكسيس

    في قسم الأكسيس Access

    قام بنشر · تم تعديل بواسطه د.كاف يار

    اخي الكريم 

    لتسهيل عملية التحديث اقترح عليك ان تستعين بــ Google drive

    بحيث تقوم برفع آخر نسخة من التعديلات الى  Google drive

    و من خلال الكود سيتم تحميل هذه النسخة الى جهاز العميل او المستخدم الآخر

    و حتى يتم ذلك يجب ان تقوم بإنشاء Module جديد و الصق فيه الكود التالي 

    Option Compare Database
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _
        ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
        Alias "URLDownLoadToFileA" (ByVal pCaller As Long, _
        ByVal szURL As String, ByVal szFileName As String, _
        ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
#End If

Function downloadFile( _
    ByVal FileURL As String, _
    ByVal FilePath As String) _
As Boolean
    Const ProcName As String = "downloadFile"
    On Error GoTo clearError
    
    URLDownloadToFile 0, FileURL, FilePath, 0, 0
    downloadFile = True

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function

Sub downloadGoogleDrive(FilePath As String, FileID As String)
    
    Const UrlLeft As String = "http://drive.google.com/u/0/uc?id="
    Const UrlRight As String = "&export=download"
        
    Dim Url As String: Url = UrlLeft & FileID & UrlRight
    
    Dim wasDownloaded As Boolean
    wasDownloaded = downloadFile(Url, FilePath)
    If wasDownloaded Then
        MsgBox "Success"
    Else
        MsgBox "Fail"
    End If

End Sub

Sub NewFileText()
On Error Resume Next
Dim FileSeveTo As String
FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _
                                                Len(CurrentProject.FullName) _
                                                - InStrRev(CurrentProject.FullName, "\"))
Dim GoogleFileID As String: GoogleFileID = "1DQqZYciRIs_dcBE6JLeoqiB3zjcq2SpL"
Call downloadGoogleDrive(FileSeveTo, GoogleFileID)

Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oFile As Object
Set oFile = fso.CreateTextFile(CurrentProject.Path & "\UpdateFile.cmd")
    oFile.WriteLine "@Echo OFF"
    oFile.WriteLine "SLEEP 3"
    oFile.WriteLine "copy " & """" & FileSeveTo & """" & " " & """" & CurrentProject.FullName & """" & " /Y"
    oFile.WriteLine "call " & """" & CurrentProject.FullName & """"
    oFile.WriteLine "exit"
    oFile.Close
Set fso = Nothing
Set oFile = Nothing
'تشغيل ملف النظام
Dim RetVal
    RetVal = Shell(CurrentProject.Path & "\UpdateFile.cmd", 1)
Application.CloseCurrentDatabase
End Sub

     

     

    و للاستدعاء لتحميل الملف و استبدال النسخة الحالية للمستخدم 

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

    '===========================================================================
Dim GoogleFileID As String: GoogleFileID = "مفتاح الملف من قوقل درايف"
'===========================================================================
Dim FileSeveTo As String
FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _
                                                Len(CurrentProject.FullName) _
                                                - InStrRev(CurrentProject.FullName, "\"))

Call downloadGoogleDrive(FileSeveTo, GoogleFileID)

     

     

     

    • Like 5

    طرح تواريخ عمودى

    في قسم الأكسيس Access

    قام بنشر

    13 ساعات مضت, omar19-3 said:

    شكرا د.كاف يار على الرد..

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

    Presentation1.jpg.7f68993ce31efceca9a6b1290165589f.jpg

    ما ذا تقصد بالطرح في التاريخ ؟

    (فالتواريخ المراد وضعها فى العمود الجديد تمثل أكبر ناتج طرح للتواريخ)

    لو اردت حساب مدة بين تاريخين استخدم التالي 

    DateDiff(«interval»; «date1»; «date2»)

    حيث ان interval

    تعبر عن معيار الحساب

    مثلا لو اردت حساب عدد الأيام بين تاريخين يكون بالطريقة التالية 

    DateDiff("D"; [date1]; [date2])

    و لو اردت حساب عدد الأشهر تكون بالطريقة التالية 

    DateDiff("M"; [date1]; [date2])

    و لو اردت حساب عدد السنوات تكون بالطريقة التالية 

    DateDiff("YYYY"; [date1]; [date2])

    و لو اردت حساب عدد الأسابيع تكون بالطريقة التالية 

    DateDiff("WW"; [date1]; [date2])

    و لو اردت حساب الربع سنوي تكون بالطريقة التالية 

    DateDiff("Q"; [date1]; [date2])

     

    • Like 1

    هل نستطيع جلب حقل او اثنين من الاكسال الى اكسيس

    في قسم الأكسيس Access

    قام بنشر

    تفضل هذا التعديل لتجاوز الخطأ 

    Public Function importExcel(Tablename As String, FilePath As String)
On Error Resume Next
Dim xlApp                   As Excel.Application
Dim xlWb                    As Excel.Workbook
Dim xlWs                    As Excel.Worksheet
Dim intLine                 As Long
Dim strSqlDml               As String
Dim strColumn1 As String, strColumn2 As String, strColumn3 As String

Set xlApp = New Excel.Application
    xlApp.Visible = False

Set xlWb = xlApp.Workbooks.Open(FilePath)
Set xlWs = xlWb.Worksheets(1)
    intLine = 2            'سيتم استيراد الصفوف بدء من الصف رقم 2

Do
    strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل
    strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل
    strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل
    
    strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')"
    CurrentDb.Execute strSqlDml, dbFailOnError
    xlWs.Cells(intLine, 1).Select
    intLine = intLine + 1
Loop Until IsEmpty(xlWs.Cells(intLine, 1))

    xlWb.Close False
    xlApp.Quit

Set xlApp = Nothing
Set xlWb = Nothing
Set xlWs = Nothing
End Function

     

    • Like 2

    هل نستطيع جلب حقل او اثنين من الاكسال الى اكسيس

    في قسم الأكسيس Access

    قام بنشر

    6 دقائق مضت, derbali ammar said:

    1/ المكتبة التي ذكرتها لم اجدها و انما وجدت المكتبة التالية المبينة بالصورة 

     

    ممتاز ثبتها و جرب الكود

     

    6 دقائق مضت, derbali ammar said:

    2/ عندما اردت استيراد الحقول ظهر هذا الخطا 

     

    استبدل الكود بالتالي 

    Public Function importExcel(Tablename As String, FilePath As String)

Dim xlApp                   As Excel.Application
Dim xlWb                    As Excel.Workbook
Dim xlWs                    As Excel.Worksheet
Dim intLine                 As Long
Dim strSqlDml               As String
Dim strColumn1 As String, strColumn2 As String, strColumn3 As String

Set xlApp = New Excel.Application
    xlApp.Visible = False

Set xlWb = xlApp.Workbooks.Open(FilePath)
Set xlWs = xlWb.Worksheets(1)
    intLine = 2            'سيتم استيراد الصفوف بدء من الصف رقم 2

Do
    strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل
    strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل
    strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل
    
    strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')"
    CurrentDb.Execute strSqlDml, dbFailOnError
    xlWs.Cells(intLine, 1).Select
    intLine = intLine + 1
Loop Until IsEmpty(xlWs.Cells(intLine, 1))

    xlWb.Close False
    xlApp.Quit

Set xlApp = Nothing
Set xlWb = Nothing
Set xlWs = Nothing
End Function

     

    • Like 3

    هل نستطيع جلب حقل او اثنين من الاكسال الى اكسيس

    في قسم الأكسيس Access

    قام بنشر

    ارفق مثال لكي يتم التعديل عليه

    او اتبع الطريقة التالية

    اولا ارفق استدعي المكتبة التالية

    image.png.5fc9a6353dee29fbd4f997e6e3ebbb92.png

     

    ثانيا / الصف الكودي التالي في اي مكان داخل المحرر 

    Public Function importExcel(Tablename As String, FilePath As String)

Dim xlApp                   As Excel.Application
Dim xlWb                    As Excel.Workbook
Dim xlWs                    As Excel.Worksheet
Dim intLine                 As Long
Dim strSqlDml               As String
Dim strColumn1 As String, strColumn2 As String, strColumn3 As String

    varfile = FilePath

Set xlApp = New Excel.Application
    xlApp.Visible = False

Set xlWb = xlApp.Workbooks.Open(varfile)
Set xlWs = xlWb.Worksheets(1)
    intLine = 2            'سيتم استيراد الصفوف بدء من الصف رقم 2

Do
    strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل
    strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل
    strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل
    
    strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')"
    CurrentDb.Execute strSqlDml, dbFailOnError
    xlWs.Cells(intLine, 1).Select
    intLine = intLine + 1
Loop Until IsEmpty(xlWs.Cells(intLine, 1))

    xlWb.Close False
    xlApp.Quit

Set xlApp = Nothing
Set xlWb = Nothing
Set xlWs = Nothing
End Function

    و في ازرار استيراد البيانات الصق الكود التالي 

    Dim Addfile As Object: Set Addfile = Application.FileDialog(3)
With Addfile: .Filters.Add "All Files", "*.xlsx"
    If .Show = True Then
        ' Call importExcel("Table Name", "File Path")
        Call importExcel("tb1", Trim(.SelectedItems(1)))
	End if
End With

     

     

    • Like 3

    مساعدة في انشاء رزنامة مدرسة

    في قسم الأكسيس Access

    قام بنشر

    في 24‏/5‏/2022 at 15:52, Moosak said:

    انتهيت ولله الحمد 😄

    image.png.195138c26171a2b47446a77207836ee1.png

    للتحميل من المرفقات ( دعوة للتجربة وإبداء الرأي ) 😊:

    الروزنامة الأسبوعية.accdb 1.93 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 6 downloads

    ماشاء الله لا قوة الا بالله

    عمل اكثر من احترافي و تنسيق اكثر من رائع

    و اختيار جميل جدا للألوان

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

    • Like 2

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

    في قسم الأكسيس Access

    قام بنشر

    تفضل التعديل

    سيتم انشاء مجلد بإسم (ملفات الأفراد)

    و سيتم انشاء مجلدات داخل مجلد ( ملفات الأفراد ) برقم الملف

    و سيتم انشاء مجلدات حسب القائمة داخل كل مجلد برقم الملف بالإسم حسب القائمة

    sa1.0.zip

    • Like 3
×
×
  • اضف...

Important Information

  I accept