استخراج أسماء الجداول و الحقول الى ملف اكسيل

[محمد طاهر عرفه]

هذا الموضوع أتصور أنه سبق طرحه ،و لكن بحثت عنه و لم أجده لذا سأضيفه ثانية حيث احتجته مؤخرا و لم أجده

الفكرة هي الرغبة فى استخراج أسماء الجداول و الحقول الى ملف اكسيل و ذلك بغرض استخدامها فى توثيق معلومات قاعدة البيانات

ضع موديول (وحدة نمطية) جديدة فى القاعدة ، ثم انسخ الكود التالي اليها

ثم شغله باستخدام F5

و لا اعتقد انه من المفيد وضع زر لتشغيله حيث عادة ما تحتاج لاجراء هذه العملية مرة واحدة او مرات قليلة لكل قاعدة تقوم بتصميمها ، اذا ما ما كنت ستقوم بتوثيقها أو كتابة تقرير عنها

و ستكون النتيجة تكوين ملف اكسيل يحوي أربعة أعمدة الاول يحوي اسم الجدول و الثاني يحوي اسماء الحقول

و الثالث يحوي على نوع الحقل ، و الأخير يدل على سعة الحقل

و لا تنسي توسيع اول عمودان فى الاكسيل بعد أن ينفتح الملف

منقول بتصرف و اضافة

Option Compare Database

Option Explicit


Sub ListTablesAndFields()

	 'Macro Purpose:  Write all table and field names to and Excel file


	Dim lTbl As Long

	Dim lFld As Long

	Dim dBase As Database

	Dim xlApp As Object

	Dim wbExcel As Object

	Dim lRow As Long


	 'Set current database to a variable adn create a new Excel instance

	Set dBase = CurrentDb

	Set xlApp = CreateObject("Excel.Application")

	Set wbExcel = xlApp.workbooks.Add


	 'Set on error in case there is no tables

	On Error Resume Next


	 'Loop through all tables

	For lTbl = 0 To dBase.TableDefs.Count - 1

		 'If the table name is a temporary or system table then ignore it



		If Left(dBase.TableDefs(lTbl).Name, 1) = "~" Or _

		Left(dBase.TableDefs(lTbl).Name, 4) = "MSYS" Then

			 '~ indicates a temporary table

			 'MSYS indicates a system level table

		Else

			 'Otherwise, loop through each table, writing the table and field names

			 'to the Excel file

			For lFld = 0 To dBase.TableDefs(lTbl).Fields.Count - 1

				lRow = lRow + 1

				With wbExcel.sheets(1)

					.range("A" & lRow) = dBase.TableDefs(lTbl).Name

					.range("B" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Name

					.range("C" & lRow) = FieldType(dBase.TableDefs(lTbl).Fields(lFld).Type)

					.range("D" & lRow) = dBase.TableDefs(lTbl).Fields(lFld).Size


			   End With

			Next lFld

		End If

	Next lTbl

	 'Resume error breaks

	On Error GoTo 0


	 'Set Excel to visible and release it from memory

	xlApp.Visible = True

	Set xlApp = Nothing

	Set wbExcel = Nothing


	 'Release database object from memory

	Set dBase = Nothing


End Sub


Function FieldType(intType As Integer) As String


   Select Case intType

	  Case dbBoolean

		 FieldType = "dbBoolean"

	  Case dbByte

		 FieldType = "dbByte"

	  Case dbInteger

		 FieldType = "dbInteger"

	  Case dbLong

		 FieldType = "dbLong"

	  Case dbCurrency

		 FieldType = "dbCurrency"

	  Case dbSingle

		 FieldType = "dbSingle"

	  Case dbDouble

		 FieldType = "dbDouble"

	  Case dbDate

		 FieldType = "dbDate"

	  Case dbText

		 FieldType = "dbText"

	  Case dbLongBinary

		 FieldType = "dbLongBinary"

	  Case dbMemo

		 FieldType = "dbMemo"

	  Case dbGUID

		 FieldType = "dbGUID"

   End Select

[ابو ياسر]

]أصالة عن نفسي ونيابة عن كل مرتادي هذا المنتدى أتقدم بالشكر الوافر الجزيل وبالامتنان والعرفان للقائم على هذا المنتدى الرجل الفاضل الشهم الكريم محمد طاهر

أسعد الله أيامك ولياليك وأصلح لك ذريتك ، وأجزل لك الثواب ، وجعل ما تقوم به في ميزان حسناتك

تم تعديل أبريل 20, 2009 بواسطه sabha

[rudwan]

بارك الله فيك استاذنا محمد

[Mohamed Nada]

بارك الله فيك أستاذنا محمد طاهر...

أتعرف لقد خطرت هذه الفكرة على بالى مرات عديدة .. ولكننى تخيلت أن هذا غير ممكن .. فأصرف نظر عنه.

الله ينور عليك دايماً تطلع فى الوقت المناسب بحلول رائعة.

تحياتى لشخصك الكريم

محمد ندا

تم تعديل مايو 2, 2009 بواسطه Mohamed Nada

[ابو يامن]

مشكور أخي محمد على هذه الإضافة الرائعة

بالفعل شيء جميل

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