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

تفضلي اختي :)

لمعرفة الكود ،

اضغطي اولا على الزر "اجمع بيانات الجداول ادناه" ، والذي سيحفظ لكي بيانات الجداول بصيغة csv ويفتح لكي اكسل بالبيانات ،

ثم الزر "استيراد البيانات" ، والذي ياخذ البيانات من صفحة الانترنت ، ويحفظها في قاعدة البيانات :)

رجاء امسحي بيانات الجدول اولا قبل تجربة البرنامج ، لأن خانة Identity لا تسمح بتكرار الرقم :)

جعفر

92.WebImport.mdb.zip

أستاذي الفاضل جعفر

شكرا جزيلا على المساعدة .. بالفعل هو المطلوب وفكرتك رائعة

هل من الممكن جعل الكود يقوم بالتحديث إذا كان Identity موجود وإذا لم يكن موجود يقوم بالإضافة ؟

رحم الله والديك وأصلح لك أولادك

الله يسهل لك أمرك كما سهلت لي أمري

حياك الله :)

سهله :)

في الكود اللي عندك ، بدل rst.addnew ، حطي هاي المعادلة (وصلى الله وبارك :) ):

if len(a7 & "")=0 then
rst.edit
else
rst.addnew
endif

جعفر

عفوا ، سؤال :

> إذا كان Identity موجود

موجود في الجدول او موجود في صفحة الانترنت؟

جعفر

بارك الله فيك

في الجدول

تفضلي اختي :)

بدل rst.AddNew

خلينا الكود التالي:

rst.FindFirst "[identity]='" & a7 & "'"

If rst.NoMatch Then
rst.AddNew
Else
rst.Edit
End If

جعفر

92.WebImport.mdb.zip

كل الشكر والتقدير بابن الطيبين

حياك الله :)

اقتباس

 

أستاذي الفاضل جعفر

 

شكرا جزيلا على المساعدة .. بالفعل هو المطلوب وفكرتك رائعة

وأنا أثني على قولك.. بالفعل فكرة رائعة...

هذه المشاركة تعليمية 

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

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

لكن إذا كان في الصفحة أكثر من جدول فيمكن الوصول إلى الجدول عن طريق رقمه التسلسلي ضمن عناصر الصفحة.. يبدأ الترقيم بالرقم (0) وهو في الصفحة المثال: الجدول الثالث ويحمل التسلسل رقم (2). وهذه الشفرة الموصلة إليه

Set Tbl = WD.getElementsByTagName("table")

تعيد هذه الشفرة مصفوفة بكافة الجداول

وللوصول إلى عناصر البينات في الجدول الثالث نستخدم الشفرة التالية

Set TD = Tbl(2).getElementsByTagName("td")

تعيد هذه الشفرة صفوفة بكافة عناصر البييانات

وهي نفس ما قام بعمله الاستاذ جعفر بالضبط لكن بتركيز أكبر

لكون البيانات في الجدول غير منتظمة فإنه من الصعب الوصول مسميات عناصر البياناتن ولهذا لجأ الا الاستاذ جعفر دوارة (For) لإعادة كافة البيانات

 For i = 0 To TD.length - 1
 If (i Mod 2) Then
 RW = RW & (TD(i).innerText) & vbTab
 End If
 Next

- استخدمت الخصيصة (length) لمعرفة طول المصفوف، لأن (Count) لاتعمل هنا

- استخدمت العبارة (Mod) لمعرفت الاعداد الفردية.. تعيد (0) إذا كان الرقم يقبل القسمةعلى (2), وأكبر من (0) إذا كان العكس.. يعني تعيد باقي القسمة.. وهذا يعني أن العدد فردي.

- كدست البينات العايدة من المصفوفة في المتغير (RW) وفصلت بينها بمسافة ثابتة (vbTab)

- قمت بتحويل البيانات إلى مصفوفة وسلمتها للوظيفة ()DR

هذه شفرة الوظيفة بالكامل

Function DR()
    Dim Tbl As IHTMLElement, TD As IHTMLElement
    Set Tbl = WD.getElementsByTagName("table")
    Set TD = Tbl(2).getElementsByTagName("td")
    For i = 0 To TD.length - 1
        If (i Mod 2) Then
            RW = RW & (TD(i).innerText) & vbTab
        End If
    Next
    DR = Split(RW, vbTab)
End Function

أقترح على الاستاذة لمياء أن تقوم بترتيب البيانات بنفس ترتيب البيانات في صفحة الموقع وذلك لتسهيل نقل البيانات بأقل كلفة من الأخطاء.

كما أقترح جعل حقل الاسم مطابقا لحقل الاسم في صفحة الموقع! وذلك للإشكاليات التي تقع في الأسماء المركبة... 

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

Sub DoTrans()
'On Error Resume Next
Dim RS As Recordset
 Set RS = CurrentDb.OpenRecordset("Select * From tblTeachers")
 RS.FindFirst "Identity='" & DR(0) & "'"

If RS.NoMatch Then
    RS.AddNew
    For i = 0 To RS.Fields.Count
        RS(i) = DR(i)
    Next
    RS.Update
Else
    RS.Edit
    For i = 1 To RS.Fields.Count
        RS(i) = DR(i)
    Next
    RS.Update
End If
RS.Close
End Sub

- يمكن تفنيد هذه الشفرة كما فعل الاستاذ جعفر

- في التحديث تحاشيت تحديث حقل مفتاح البيانات لأن ذلك يسبب حوث بيانات متكررة

أرجو أن يكون في هذه المشاركة مزيد معرفة للجميع... وهذى الشفرة بالكامل

Private Sub Form_Load()
    DoCmd.Maximize
    '- OPEN THE WEB PAGE IN THE WEB BROWSER OBJECT
    Me.WebBrowser4.Silent = True
    Me.WebBrowser4.Navigate CurrentProject.Path & "\Takamul.htm"
End Sub

Function WB() As WebBrowser
    Set WB = Me.WebBrowser4.Object
End Function

Function WD() As HTMLDocument
    Set WD = WB.Document
End Function

Function DR()
    Dim Tbl As IHTMLElement, TD As IHTMLElement
    Set Tbl = WD.getElementsByTagName("table")
    Set TD = Tbl(2).getElementsByTagName("td")
    For i = 0 To TD.length - 1
        If (i Mod 2) Then
            RW = RW & (TD(i).innerText) & vbTab
        End If
    Next
    DR = Split(RW, vbTab)
End Function

Sub DoTrans()
'On Error Resume Next
Dim RS As Recordset
 Set RS = CurrentDb.OpenRecordset("Select * From tblTeachers")
 RS.FindFirst "Identity='" & DR(0) & "'"

If RS.NoMatch Then
    RS.AddNew
    For i = 0 To RS.Fields.Count
        RS(i) = DR(i)
    Next
    RS.Update
Else
    RS.Edit
    For i = 1 To RS.Fields.Count
        RS(i) = DR(i)
    Next
    RS.Update
End If
RS.Close
End Sub

Private Sub ÃãÑ81_Click()
 Call DoTrans
End Sub