الكود التالي يقوم بنسخ جميع العناوين الموجودة في المفضلة بحيث تظهر في حقل عنوان الرابط اسم العنوان وحقل المجلد اسم المجلد الموجود فيه وحقل الرابط عنوان الموقع .
و يلزم إنشاء جدول بثلاثة حقول :
عنوان الرابط ونوعه رابط تشعبي
المجلد ونوعه نص حجمه لا يقل عم 100
الرابط مذكرة
المشكلة هذا الكود يترك بعض العناوين بسبب القفز الموجود في الدالة الأولى لوجود خطأ لم أعرف سببه ووجود On Error في الدالة الثانية .
ملاحظة الخطأ لا يظهر إلا عند وصول عدد العناوين بين 900 والألف .
الخطأ يظهر في الكود في السطر :
Input #1, Useless
في الدالة الثانية .
فمن يخبرني ما الخطأ ؟
الكود :
Option Compare Database
Private Sub أمر0_Click()
GetListing "C:WINDOWSFavorites", "*.url"
End Sub
Private Sub GetListing(strDir$, strFile$)
Dim varrDir As Variant
Dim ivarrCount
Dim strFileName$
Dim strDirName$
Do While Right(strDir$, 2) = ""
strDir$ = Mid(strDir$, 1, Len(strDir$) - 1)
DoEvents
Loop
strDirName$ = Dir(strDir$, vbDirectory)
Do While strDirName$ = "." 'Or strDirName$ = ".."
strDirName$ = Dir()
DoEvents
Loop
ivarrCount = 1
ReDim varrDir(ivarrCount) As Variant
Do While strDirName$ <> ""
DoEvents
If InStr(strDirName$, ".") = 0 Then
varrDir(ivarrCount) = strDirName$
ivarrCount = UBound(varrDir) + 1
ReDim Preserve varrDir(ivarrCount) As Variant
End If
strDirName$ = Dir()
Loop
strFileName$ = Dir(strDir$ & strFile$)
' هنا الإضافة
Dim dbs As DAO.Database
Dim Rst As DAO.Recordset
Set dbs = CurrentDb
Set Rst = dbs.OpenRecordset("روابط")
Dim strGrab As String
Dim strPart As String
Dim intFileNum As Integer
Do While strFileName$ <> ""
strGrab = GetURLFromFile(strDir$ & strFileName$)
If strGrab = "" Then GoTo 10
With Rst
.AddNew
![عنوان الرابط] = Left(strFileName$, Len(strFileName$) - 4) & "#" & strFileName
If Left(Left(strGrab, Len(strGrab) - 2), 5) <> "http:" Then
![عنوان الرابط] = Left(strFileName$, Len(strFileName$) - 4) & _
"#" & "http:" & Left(strGrab, Len(strGrab) - 2)
Else
![عنوان الرابط] = Left(strFileName$, Len(strFileName$) - 4) & _
"#" & Left(strGrab, Len(strGrab) - 2)
End If
!المجلد = Right(Left(strDir$, Len(strDir$) - 1), InStr(StrReverse(Left(strDir$, Len(strDir$) - 1)), "") - 1)
![الرابط] = strGrab
.Update
End With
10 strFileName$ = Dir()
Loop
For i = 1 To UBound(varrDir)
DoEvents
If varrDir(i) = "" Then Exit For
GetListing strDir$ & CStr(varrDir(i)) & "", strFile$
Next
ExitOut:
End Sub
Private Function GetURLFromFile(Filename As Variant) As String
On Error Resume Next
Dim Useless, URL As String
Open Filename For Input As #1
If Not EOF(1) Then ' Check for end of file.
Input #1, Useless
Input #1, URL
End If
Close #1
If Left$(URL, 4) = "URL=" Then
URL = Right$(URL, Len(URL) - 4)
ElseIf Left$(URL, 4) = "BASE" Then
URL = Right$(URL, Len(URL) - 8)
End If
GetURLFromFile = URL
End Function