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

[mazoolagh]

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

[mazoolagh]

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

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


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


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

[mazoolagh]

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

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


154764

[mazoolagh]

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

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

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

[mazoolagh]

برچسب‌ها
154770
154771


پیوست‌ها
154772
154773

[mazoolagh]

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

[mazoolagh]

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

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

154778

[mazoolagh]

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

154779

[mazoolagh]

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

154780

154781

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

[mazoolagh]

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

154782

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

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

[mazoolagh]

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

154783

[mazoolagh]

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

154784

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

[mazoolagh]

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

154785

[mazoolagh]

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

154786

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

[mazoolagh]

برچسب‌ها (tags)

154787

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

[mazoolagh]

پیوست‌ها (attachments)

154788

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

[mazoolagh]

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

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

154789

[mazoolagh]

154790

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

[mazoolagh]

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

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

154794

[mazoolagh]

پیش از هر چیز نیاز به تابعی داریم که با گرفتن یک 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

[mazoolagh]

متن بخش‌های زمان ساخت و زمان بروزرسانی به دلایل زیر مستقیما قابل استفاده نیست:
۱- بودن کارآکترهای اضافی (احتمالی) مانند 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

[mazoolagh]

اکنون میتوانیم تابع تبدیل 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

[mazoolagh]

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:last-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

[mazoolagh]

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


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


154797



به دلیل محدودیت سایز فایل پیوست به 480 کیلوبایت، برنامه نمونه به اندازه 567 کیلوبایت را از اینجا (https://drive.google.com/file/d/16wkKDGMnCp2Imyw0L6jv8Al-fnDuXlYI/view?usp=sharing)بگیرید.