ساخت یک دیتابیس از همه تاپیک‌ها و پست‌های تالار اکسس - Web Scraping in Access VBA

1. در این تاپیک روش بیرون کشیدن دیتا از برگه‌های وب (Web Scraping یا Harvesting) با استفاده از اکسس آموزش داده میشود.
2. فرض بر این است که خواننده اطلاعات کافی از HTML DOM و Browser DevTools دارد.
3. آموزش روی همین تالار اکسس از فروم برنامه نویس پیاده میشود.
4. ابتدا برگه‌های تالار و هر تاپیک آنالیز شده و سپس متدهای دسترسی به هر بخش از دیتا طراحی و تست میشود. کد نویسی آخرین بخش کار خواهد بود.

بخش‌هایی که در برگه نخست دیده میشود و دیتا آن بتنهایی یا برای انجام کار نیاز است:

بخش صفحه‌بندی - برای پیدا کردن تعداد کل برگه‌ها نیاز به آن داریم
ضمیمه 154761
این بخش در همه برگه‌ها هست - ولی باید در همان برگه نخست از روی آن تعداد کل برگه‌ها را پیدا کرد تا بتوانیم حلقه پیمایش را بنویسیم.


بخش تاپیکهای اعلان (stickies)
ضمیمه 154762
این بخش فقط در برگه نخست دیده میشود. پس باید در همان برگه نخست دیتا آن را بیرون بکشیم.


بخش تاپیک‌های عادی
ضمیمه 154763
دیتا این بخش در هر برگه باید جداگانه بیرون کشیده شود.

از نظر ساختاری و محتوا تفاوتی بین تاپیک‌های اعلان و عادی نیست.
بخش‌هایی که دیتا آن ارزشمند بنظر میرسد:

• نام کاربری سازنده تاپیک
• عنوان
• تاریخ ساخت
• برچسب‌ها (tags)
• تعداد پیوست‌ها
• تعداد پاسخ‌ها
• تاریخ بروزرسانی (برای دانستن این که تاپیک پس از آخرین درو آپدیت شده یا نه)

ضمیمه 154764

پیش از هر چیز باید روش آدرس‌دهی برگه‌ها را بدانیم.

آدرس برگه نخست تالار اکسس به شکل زیر است:

https://barnamenevis.org/forumdisplay.php?23-Access

و برای آدرس‌دهی عمومی برگه Nام:

https://barnamenevis.org/forumdisplay.php?23-Access/pageN

پس ما برای آدرس‌دهی برگه اول هم از همین فرمت عمومی استفاده میکنیم تا کد بهتری داشته باشیم (یک کد برای همه برگه ها)

-----------------

در مرورگر آدرس برگه نخست رو میزنیم و سپس DevTools رو باز میکنیم:

از بخش page navigation شروع میکنیم تا تعدادکل برگه‌ها رو ببینیم
ضمیمه 154765


بخش تاپیک‌های اعلان (stickies)
ضمیمه 154766


بخش تاپیک‌های عادی
ضمیمه 154767


سازنده تاپیک
ضمیمه 154768
ضمیمه 154769

برچسب‌ها
ضمیمه 154770
ضمیمه 154771


پیوست‌ها
ضمیمه 154772
ضمیمه 154773

تاریخ بروزرسانی
ضمیمه 154775
ضمیمه 154776

حالا میتونیم در DevTools مرورگر برای هر بخش یک selector مناسب بنویسیم و تست کنیم:

در زمان کدنویسی همین selector هست که باید پیاده بشه.

ضمیمه 154778

تاپیک‌های اعلان (stickies)

ضمیمه 154779

تاپیک‌های عادی (threads)

ضمیمه 154780

ضمیمه 154781

مشخصا در هر برگه ۲۰ تاپیک هست.

شماره پاسخ‌ها (replies)

ضمیمه 154782

اگر این بخش خالی باشه به معنای این هسا که تاپیک در دسترس نیست (منتقل شده یا پاک شده)

برای همین در هر thread نخست این رو بررسی میکنیم و اگر مقدار نداشت میریم سراغ تاپیک بعدی.

عنوان تاپیک (title)

ضمیمه 154783

زمان ساخت تاپیک

ضمیمه 154784

نگهداری زمان به این شکل در دیتابیس درست نیست.
در زمان کدنویسی این مقدار باید به شکل مناسب تبدیل شود.

سازنده تاپیک (author)

ضمیمه 154785

زمان بروزرسانی

ضمیمه 154786

مشابه زمان ساخت این مقدار نیز در زمان کدنویسی باید ویرایش شود.

برچسب‌ها (tags)

ضمیمه 154787

این بخش ممکن است خالی باشد بنابراین در زمان کدنویسی نخست وجود آن را چک میکنیم.

پیوست‌ها (attachments)

ضمیمه 154788

این بخش نیز ممکن است وجود نداشته باشد.
مشابه برچسب‌ها عمل میکنیم.

در این پروژه از کتابخانه mshtml استفاده میکنیم.
mshtml موتور رندرینگ internet explorer و انتخاب کاملا مناسبی است
که تمام نیازهای ما (و خیلی بیشتر از آن) را بسادگی برآورده میکند.

پس کافی هست رفرنس آن را به برنامه اضافه کنیم:

ضمیمه 154789

ضمیمه 154790

از فیلد UpdateRequired برای تشخیص این که آیا تاپیک از زمان آخرین scraping آپدیت شده استفاده میکنیم.
کاربرد آن زمانی است که بخواهیم همه پست‌های یک تاپیک را بیرون بکشیم.

در این مبحث فرآیند بیرون کشیدن دیتا را در 2 مرحله انجام میدهیم:
1- پر کردن جدول Threads از همه تاپیک‌های فروم اکسس با پیمایش در همه برگه‌های آن
۲- پر کردن جدول Posts با پیمایش همه برگه‌های همه Threadها (مرحله بعدی آموزش)

قبل از شروع کدنویسی مرحله ۱، نخست فلوچارت کلی پروسه رو آماده میکنیم:
ضمیمه 154793

ضمیمه 154794

پیش از هر چیز نیاز به تابعی داریم که با گرفتن یک url ، محتوای آن را به صورت یک html document برگرداند:

Public HTML As HTMLDocument



Public Function GetDocument(url As String) As HTMLDocument

Set HTML = New HTMLDocument

Set GetDocument = HTML.createDocumentFromUrl(url, vbNullString)

Do Until GetDocument.ReadyState = "complete"

    DoEvents

Loop

GetDocument.Close

End Function

متن بخش‌های زمان ساخت و زمان بروزرسانی به دلایل زیر مستقیما قابل استفاده نیست:
۱- بودن کارآکترهای اضافی (احتمالی) مانند non-breaking space یا کاما (فارسی یا انگلیسی) یا rtl و ...
۲- بودن بخش‌های اضافی مانند روز هفته
۳- اسم ماه فارسی

برای همین به توابع زیر برای برداشتن این بخشها از زمان نیاز داریم:

Public blank, dbl_blank, ay, py, ak, pk, nbsp, ltr, rtl As String

Public st(1 To 13) As String

Public mt(1 To 12) As String

Public Function PersiX(x) As String

x = Nz(x, blank)

x = Replace(x, nbsp, blank)

x = Replace(x, ltr, blank)

x = Replace(x, rtl, blank)

x = Replace(x, ay, py)

x = Replace(x, ak, pk)

PersiX = RipX(x)

End Function

Public Function RipX(x) As String

x = Nz(x, blank)

Do While InStr(x, dbl_blank) > 0

    x = Replace(x, dbl_blank, blank)

Loop

RipX = Trim(x)

End Function

Public Sub Init()

blank = ChrW(&H20)  ' space

dbl_blank = blank + blank

ay = ChrW(&H64A)    ' arabic ye

py = ChrW(&H6CC)    ' persian ye

ak = ChrW(&H643)    ' arabic ke

pk = ChrW(&H6A9)    ' persian ke

nbsp = ChrW(&HA0)   ' non-breaking space

ltr = ChrW(&H200E)  ' left-to-right

rtl = ChrW(&H200F)  ' right-to-left

'------------------------

st(1) = PersiX("در تاریخ")

st(2) = PersiX("ساعت")

st(3) = PersiX("صبح")

st(4) = PersiX("عصر")

st(5) = PersiX("یک شنبه")

st(6) = PersiX("دوشنبه")

st(7) = PersiX("سه شنبه")

st(8) = PersiX("چهارشنبه")

st(9) = PersiX("پنج شنبه")

st(10) = PersiX("جمعه")

st(11) = PersiX("شنبه")

st(12) = ","

st(13) = "،"

'------------------------

mt(1) = PersiX("فروردین")

mt(2) = PersiX("اردیبهشت")

mt(3) = PersiX("خرداد")

mt(4) = PersiX("تیر")

mt(5) = PersiX("مرداد")

mt(6) = PersiX("شهریور")

mt(7) = PersiX("مهر")

mt(8) = PersiX("آبان")

mt(9) = PersiX("آذر")

mt(10) = PersiX("دی")

mt(11) = PersiX("بهمن")

mt(12) = PersiX("اسفند")

End Sub

اکنون میتوانیم تابع تبدیل GetTime را برای تبدیل فرمت زمان به شکل مناسب بنویسیم:

Public Function GetTime(s As String) As String

s = PersiX(s)

Dim i As Integer

For i = 1 To 13

    s = Replace(s, st(i), blank)  ' remove extra text

Next

    

For i = 1 To 12

    s = Replace(s, mt(i), Format(i, "00"))  ' Replace Persian Month-names to number

Next



s = RipX(s)



Dim x

x = Split(s, blank)

GetTime = x(2) + "/" + x(1) + "/" + x(0) + " - " + x(3) ' YYYY/MM/DD - HH:MM

End Function

به این ترتیب زمان به شکل زیر:
ضمیمه 154795
به فرمت مناسب زیر برای نگهداری در دیتابیس و مقایسه تبدیل میشود:

1385/06/26 - 08:07

Option Compare Database

Option Explicit



Const PageUrl = "https://barnamenevis.org/forumdisplay.php?23-Access/page"

Private Document As HTMLDocument

Private PagesCount As Integer

Private RS_threads As Recordset

Private temp_object, temp_array As Variant

Private StopProcess As Boolean

Sub Scrape_Forum_Pages()

'DoCmd.RunSQL "DELETE * FROM Threads"

Init

Dim PageNumber As Integer: PageNumber = 1

PagesCount = 1

StopProcess = False

Set RS_threads = CurrentDb.OpenRecordset("Threads", dbOpenDynaset)





Do While PageNumber <= PagesCount And (Not StopProcess)

    Scrape_Forum_Page (PageNumber)

    PageNumber = PageNumber + 1

Loop



RS_threads.Close

Set RS_threads = Nothing

Set HTML = Nothing



Scrape_New_Or_Updated_Threads

MsgBox ("Access Forum Scraping Done!")

End Sub

Sub Scrape_Forum_Page(PageNumber As Integer)



Set Document = GetDocument(PageUrl + Trim(PageNumber))



If PageNumber = 1 Then

    GetForumPagesCount

    ScrapePageThreads ("stickies")  ' sticky threads

End If



ScrapePageThreads ("threads") ' normal threads



Set Document = Nothing

Debug.Print "Page " & PageNumber & " done!   " & Time

End Sub

Sub ScrapePageThreads(ThreadsID As String)

Dim Threads As HTMLListElement

Dim Thread As HTMLListElement

Set Threads = Document.getElementById(ThreadsID)

StopProcess = False



For Each Thread In Threads.Children

    If StopProcess Then

        Exit For

    Else

        GetThreadInfo Thread

    End If

Next



Set Threads = Nothing

Set Thread = Nothing

End Sub

Sub GetThreadInfo(ByRef Thread As HTMLLIElement)



Dim ThreadID, Title, Author, CreateTime, UpdateTime, Tags As String

Dim Replies, Attachments As Integer

Dim img As HTMLImg

Dim span As HTMLSpanElement

    

temp_object = Trim(Thread.querySelector(".threadstats > li").innerText)

If temp_object = vbNullString Then Exit Sub  ' Moved Thread

temp_array = Split(temp_object, blank)

Replies = CInt(temp_array(1))



temp_array = Split(Thread.Id, "_")

ThreadID = temp_array(1)



Title = Document.getElementById("thread_title_" & ThreadID).innerText

    

Set span = Thread.querySelector(".author .label")

CreateTime = GetTime(span.childNodes.Item(2).Data)

Author = span.querySelector("a").innerText



Set img = NzImg(Thread.querySelector(".author .threaddetails img[src*='tag']"))

If img Is Nothing Then

    Tags = vbNullString

Else

    Tags = img.Title

End If



Set img = NzImg(Thread.querySelector(".author .threaddetails img[src*='paperclip']"))

If img Is Nothing Then

    Attachments = 0

Else

    temp_array = Split(img.Title, blank)

    Attachments = CInt(temp_array(0))

End If



UpdateTime = GetTime(Thread.querySelector(".threadlastpost>dd:l  ast-of-type").innerText)

    

With RS_threads

    .FindFirst "ThreadID=" & ThreadID

    If .NoMatch Then  ' New Thread

        .AddNew

        !ThreadID = CLng(ThreadID)

        !Title = Title

        !Tags = Tags

        !Author = Author

        !CreateTime = CreateTime

        !UpdateTime = UpdateTime

        !Replies = Replies

        !Attachments = Attachments

        !UpdateRequired = True

        .Update

    Else  ' Old Thread

        If !UpdateTime = UpdateTime Then  ' Unchanged Old Thread

            StopProcess = True

        Else  ' Old Thread - Updated or New Post

            .Edit

            !Title = Title

            !Tags = Tags

            !UpdateTime = UpdateTime

            !Replies = Replies

            !Attachments = Attachments

            !UpdateRequired = True

            .Update

        End If

    End If

End With



Set img = Nothing

Set span = Nothing

End Sub

Sub GetForumPagesCount()

    Dim a As HTMLAnchorElement

    Set a = Document.querySelector(".threadpagenav span.first_last > a")

    If a Is Nothing Then

        PagesCount = 1

    Else

        temp_array = Split(a.href, "/page")

        PagesCount = CInt(temp_array(1))

    End If

    Set a = Nothing

End Sub

Function NzImg(ByRef v As Variant) As HTMLImg

If IsNull(v) Then

    Set NzImg = Nothing

Else

    Set NzImg = v

End If

End Function

دیتابیس فاز ۱ : تاپیک‌ها

1. دیتابیس تا تاریخ ارسال این پست بروز است.
2. در یک سیستم معمولی و با یک اتصال اینترنت سالم خواندن دیتا حدود ۷۰۰ برگه فروم اکسس (۱۴۰۰۰ تاپیک) باید در کمتر از ۱۰ دقیقه (حدود ۷ دقیقه یا 100 برگه در دقیقه) به پایان برسد.
3. با توجه به منطق برنامه هیچگاه نیازی به پاک کردن جدول Threads و پر کردن دوباره آن نیست، برای بروزرسانی‌های بعدی کافی است روتین Scrape_Forum_Pages را اجرا کنید.
4. از این برنامه فقط با هدف یادگیری استفاده کنید، و از اجرای پیاپی آن که باعث بار ترافیکی روی سرور برنامه‌نویس میشود خودداری کنید.

ضمیمه 154797

به دلیل محدودیت سایز فایل پیوست به 480 کیلوبایت، برنامه نمونه به اندازه 567 کیلوبایت را از اینجا بگیرید.