Make your own free website on Tripod.com

تطبيقات الفيجوال بيسك في Microsoft Office

إعداد الدكتور / محمود بدر

مقدمة :

فرونت بيج FrontPage

فيجوال بيسك وورد Word :

مزيد من ماكروات Macros ورد Word :

إكسل Excel

التعامل من داخل فيجوال بيسك مع برامج التطبيقات

 

مقدمة :

ظلت فيجوال بيسك للتطبيقات VBA لسنوات عدة اللغة المستخدمة مع مايكروسوفت أوفس  M. Office  ، فهي لغة بسيطة تتيح للمبرمجين ، والمستخدمين المحترفين تنفيذ ما يلي :

1-   توسيع تطبيقات أوفس و جعلها آلية .

2-   تكامل تطبيقات أوفس  M. Office ، وإمكانية تبادل البيانات بين تطبيقات أوفس  M. Office مثل تبادل البيانات بين اكسل Excel   و ورد word .

والفكرة هي من خلال إنشاء لغة عامة ، وبيئة برمجة لعدد من التطبيقات ، بحيث يمكن للأفراد أن يخصصوا تطبيقات معينة ، ويضيفوا مقدرات جديدة للتطبيق.

 

فرونت بيج FrontPage

 

1-   انقر قائمة أدوات Tool واختر Macros.. .

2-  سوف تظهر لك النافذة التالية :

 

أكتب bbb فيظهر الزر Create انقره  سوف يفتح لك محرر فيجوال بيسك

 

 

ملحوظة : اتبع الخطوات بدقة لتجنب أخطاء .

3-  وبعد فتح محرر فيجوال بيسك ، ابحث عن  الإجراء bbb و أدخل الشفرة التالية :

 

 

Sub bbb() 'اسم الماكرو

  'التأكد من أن الصفحة مرئية وأنه مفتوح صفحة واحدة علي الأقل

   If (Application.ActiveWebWindow.ViewMode = fpWebViewPage _

      And ActiveWebWindow.PageWindows.Count > 0) Then  Dim activePage, page As PageWindow 'Declare variables

      'ضبط المتغير ActivePage  علي الصفحة الحالية

      'current active page

      Set activePage = ActivePageWindow

      'Loop through all open pages

      For Each page In ActiveWebWindow.PageWindows page.Activate

          'Click the Save button for each page

          CommandBars("Add Command").Controls("&File"). _

            Controls("&Save").Execute

      Next

      'Display the page you were working on when

      'the Save All command was clicked

      activePage.Activate

  End If

End Sub

 

4-  عد إلي فرونت بيج ، ومن قائمة Tool اختر Customize  .

 

 

علي الفور سوف تظهر لك النافذة التالية :

 

 

5-  اختر التبويب Commandf واختر Macross ، من الخانة اليمني اسحب العنوان Custom New Item بالماوس وضعه علي شريط الأدوات أو في قائمة File .

6-  انقر Custom New Item في الموضع الذي وضعته فيه ، سوف يظهر الزر Modify Selection و غير الاسم إلي حفظ الكل 

7-  انقر الزر Modify Selection مرة أخري واختر تخصيص ماكرو Asign Macro .

 

سوف تظهر لك النافذة التالية :

 

 

انقر الزر OK

8-  انقر الزر Close

 

الآن يظهر في شريط القائمة الأمر احفظ الكل ، وهو يهدف إلي حفظ كل صفحات الفرونت بيج Front Page  المفتوحة مما يسهل عليك بدلاً من حفظها فرادي .

بنفس الخطوات السابقة أنشئ الماكروز Macros  التالي :

Sub aaa()

Shell "D:\Program Files\Common Files\Microsoft Shared\PhotoEd\Photoed.exe"

End Sub

Sub ccc()

Shell "C:\WIN98\Pbrush.exe"

End Sub

 

فيجوال بيسك وورد Word :

 

1-  من قائمة أدوات انقر  ماكرو ، ومن القائمة الفرعية اختر تسجيل ماكرو جديد :

 

 

وهنا سوف تظهر لك النافذة التالية :

 

 

انقر الزر موافق .

 

سوف يظهر  لك الشكل التالي :

وهي علامة بدء تسجيل الماكرو

 

2-  انقر قائمة أدوات مرة أخري  واختر ماكرو Macro

 

 

سوف تنبثق لك النافذة التالية :

 

 

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

 

 

اكتب ما يلي :

Shell "C:\MSWLogo\logo.exe"

أو أي  مسار لملف تنفيذي .

 

3-  الآن انقر قائمة أدوات مرة أخري واختر تخصيص ثم انقر الزر أوامر Commands

 

 

اسحب اسم الماكرو Macro  إلي أعلي وضعه في شريط القوائم أو آي شريط أدوات

 ثم اضغط الزر تغيير التحديد

 

 

وأشر علي نمط افتراضي

ثم  اختر تحرير شكل  الزر  وسوف يظهر لك محرر شكل الزر كما يلي :

 

 

 

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

 

الآن يمكنك أن تدرج  نفس الماكرو Macro المذكور في  فرونت بيج Front Page في ورد  . هل يعمل بنفس الطريقة مع ضرورة تنفيذ الخطوات السابقة بالترتيب .

 

حاول أن تجرب تنفيذ عدة  ملفات تنفيذية مثل القاموس وغيره .

 

من الواضح أن تطبيق فيجوال بيسك يهدف كما سبق أن ذكرنا إلي  تقليل الوقت المستهلك في تنفيذ المهام الروتينية ، والمثال التالي يوضح بعض من المهام الروتينية التي نقوم بتنفيذها في ورد Word فمثلاً :

لنفرض أنك تقوم بالمهام التالية عند بدء  إنشاء وثيقة جديدة :

1-   نظلل كل الوثيقة .

2-   نختار الخط Arabic Transparent  .

3-   نختار حجم الخط 14 .

4-   تنسيق الوثيقة من الطرفين .

ولكي تسهل الأمر يمكنك أن تقوم بتلك المهام من خلال ماكرو Macro كما يلي :

1-   من قائمة أدوات اختر ماكرو Macro ثم تسجيل ماكرو Macro جديد .

2-   انقر موافق ثم :

أ‌-     ظلل كل الوثيقة بلمس المفتاحين Ctrl + A .

ب‌-اختر الخط Arabic Transparent .

ت‌-اختر حجم الخط 14 .

ث‌-انقر التنسيق من الطرفين

3-    انتقل إلي قائمة الأدوات مباشرة ثم اختر ماكرو Macro واختر إيقاف تسجيل ماكرو Macro .

4-   انتقي تخصيص من قائمة الأدوات واختر الأوامر ثم اختر ماكرو Macro  واسحب اسم الماكرو Macro الذي تم تسجيله إلي شريط الأدوات واختر افتراضي ثم غير الاسم لروتين  بنفس الطريقة السابقة ، وعموما سوف تجد أن ورد Word قد سجل لك  الماكرو Macro التالي :

Sub ماكرو4()

'

' ماكرو4 ماكرو

' تسجيل الماكرو ‏27‏‏/‏09‏‏/‏00‏ من قبل د. محمود إبراهيم محمد بدر'

    Selection.WholeStory    Selection.Font.NameBi = "Arabic Transparent"

    Selection.Font.SizeBi = 14

 Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify

End Sub

 

*   هل يمكنك أن تجعل الماكرو Macro يظلل منطقة محددة ويكرر ما سبق عليها .

*   أضف السطر التالي في نهاية الماكرو Macro  :

MsgBox “تم التنفيذ يا صديق

 

وقبل أن نواصل عليك اتباع الخطوات بدقة لأن الماكرو Macro قد ينفذ أشياء غير متوقعة .

 

 

أحياناً نريد طريقة سريعة لرسم الجداول مباشرة جرب الماكرو Macro التالي :

 

Sub 1MyOwnTable()

Dim iRow as integer ,iColumns as integer

Dim  myTable

IRows=InputBox(“أدخل عدد صفوف الجدول”)

Icolumns=InputBox(“أدخل عدد الأعمدة”)

If iRow >1 and iColumns >1 Then set myTable=ActiveDocument.Tables.Add(Selection.Range,Irows,Icolumns)   يجب أن يكون عدد الصفوف والأعمدة أكبر من 2

Mytable.AutoFormat Format:=wdTableFormateColorful2 Else

MsgBox “يجب أن يحتوي الجدول علي صفين وعمودين علي الأقل

EndIF

End Sub

تغيير فهرس أو المسار :

Sub تغيير_المجلد()

Dim MyPath as String

MyPath=InputBox(“أكتب مسار المجلد المطلوب”)

Application.ChangeFileOpenDirectory (“C:\&MyPath)

End Sub

 

عمل نسخ احتياطية من الملفات

Sub نسخة_احتياطية()

Dim backupFile as String

Dim CurrFile as String

With ActiveDocument

If  .Saved Or .Path=”” Then Exit Sub

.Bookmarks.Add Name:=”Last”

Application.ScreenUpdating=False

.Save

CurrFile=.FullName

BackupFile=”A:\”+.Name

.Save As FileName:=backupFile

End With

ActiveDocument.Close

Document.Open FileName:=CurrFile

ActiveDocument.GoTo what:=wdGoToLine,

Which:=wdGoTo what:=wdGoToBookmark, Name:=”Last”

End Sub

 

مزيد من ماكروات Macros ورد Word :

 

Sub CollectCaptions()

'

' This macro collects all figure captions in the text

' and appends them to the document.

' Captions are formatted with the Caption style, which is

' used to locate them in the text

 

Dim CaptionsText As String

' Move to beginning of document

Selection.HomeKey Unit:=wdStory

' Set up the Find & Replace dialog box's psrameters

Selection.Find.ClearFormatting

Selection.Find.Style = ActiveDocument.Styles("Caption")

With Selection.Find

    .Text = ""

    .Replacement.Text = ""

    .Forward = True

'    .Wrap = wdFindAsk

    .Format = True

    .MatchCase = False

    .MatchWholeWord = False

    .MatchWildcards = False

    .MatchSoundsLike = False

    .MatchAllWordForms = False

End With

' Now execute the Find operation

Selection.Find.Execute

CaptionsText = CaptionsText & Selection.Text

If (Not Selection.Find.Found) Or Selection.End Then

    FindMore = False

End If

FindMore = True

' Repeat the Fid operation as long as there are more instances

' of the text being searched

While FindMore

    Selection.Find.Execute

' Stop searching if last find operation was not successful

    CaptionsText = CaptionsText & Selection.Text

    If (Not Selection.Find.Found) Then

        FindMore = False

    End If

Wend

' Insert spaces before the list of captions

CaptionsText = vbCrLf & vbCrLf & vbCrLf & "L I S T   O F   C A P T I O N S" & vbCrLf & CaptionsText

' Append list of captions to text

Selection.EndKey Unit:=wdStory

Selection.Text = CaptionsText

' Set Normal style, or else it may be formatted in the

' document's last paragraph's style

Selection.Style = "Normal"

End Sub

 

إكسل Excel

يوفر برنامج إكسل Excel مجموعة من كائنات  Com ، مثل Application ، و Sheet ، و Workbook ، ويمكن للمبرمج إنشاء هذه العناصر داخل برنامجه ، ثم استخدامها كوسيلة للوصول إلي جميع خدمات البرنامج .

 

مثال (1) :

شغل برنامج إكسل Excel ومن قائمة أدوات انتقي ماكرو Macro ثم تسجيل ماكرو Macro جديد :

 

 

علي الفور تظهر لك النافذة التالية :

 

 

انقر الزر موافق

2 – انتقي من قائمة أدوات ماكرو Macro ثم وحدات الماكرو Macro :

 

 

علي الفور تظهر لك نافذة تحوي بالماكروات Macros الموجودة .

 

 

انقر تحرير وضع في المحرر الشفرة التالية :

Sub ماكرو1()

'

' ماكرو1 ماكرو

' الماكرو مسجل ‎28/09/2000 بواسطة ‎د. محمود إبراهيم محمد بد'

 

'

10  Dim App As Excel.Application

20  Dim Book As Excel.Workbook

30  Dim Sheet As Excel.Worksheet

'انشاء تطبيق اكسل

40 Set App = CreateObject("Excel.application")

'جعل تطبيق إكسل مرئي

50 App.Visible = True

'إنشاء work book خالي

60 Set Book = App.Workbooks.Add

70 Set Sheet = Book.Worksheets(1)

'وضع نص في الخلية A1

80  Sheet.Cells(1, 1).Value = "هذه هي الخلية A1"

'وضع نص في الخلية A2

90 Sheet.Cells(2, 1).Value = "هذه هي الخلية A2"

100 Sheet.Cells(2, 1).Font.Color = vbBlue

End Sub

 

الآن انتقل إلي إكسل Excel ، ومن قائمة أدوات انتقي تخصيص  ثم أوامر ثم وحدات ماكرو Macro كما بالنافذة التالية :

 

 

اسحب عنصر قائمة مخصص إلي شريط الأدوات  ثم انقر تعديل التحديد فتظهر النافذة التالية :

 

 

بعد انتقاء تعيين ماكرو Macro تظهر لك النافذة التالية :

 

 

اضغط موافق ، والآن ربما ترغب في تقليل حجم النص الذي يشير لاسم الماكرو Macro وهو عنصر قائمة جديد ، انقر تعديل التحديد و إلي  الاسم اكتب تجربة

 

 

الآن أغلق النافذة وسوف تجد زر في شريط الأدوات يحمل اسم تجربة ، وهنا أصبح الماكرو Macro جاهزاً  انقر الماكرو Macro تجربة تحصل علي الشكل التالي :

 

 

مزيد من الماكروات Macros :

' To uncomment the following declaration

' first add a reference to the Excel 8.0 Object Library

'Public appExcel As Excel.Application

 

Public appExcel As Object

 

Sub main()

    On Error Resume Next

    Set appExcel = GetObject(App.Path & "\FRMSales.xls", "Excel.Application")

    If appExcel Is Nothing Then

        Set appExcel = CreateObject("Excel.Application")

        appExcel.Workbooks.Open App.Path & "\FRMSales.xls"

    End If

    VBEXCEL.Show

End Sub

 

مثال :

لنفرض اننا نريد أن ننشئ جدول للضرب

استخدم الشفرة التالية :

Sub ماكرو1()

'

' ماكرو1 ماكرو

' الماكرو مسجل ‎28/09/2000 بواسطة ‎د. محمود إبراهيم محمد بد'

 

'

10 Dim app As Excel.Application

20 Dim book As Excel.Workbook

30 Dim sheet As Excel.Worksheet

'إنشاء هدف في إكسل

40 Set app = CreateObject("Excel.Application")

'إنشاء كتاب عمل خاوي

50 Set book = app.Workbooks.Add

'الحصول علي إسناد للشيت الأول في كتاب العمل

60 Set sheet = book.Worksheets(1)

'ملئ العمود الأيسر من الجدول

70 Dim row As Integer

80 For row = 1 To 10

90 sheet.Cells(row + 1, 1).Value = row

100 Next row

'ملئ الصف العلوي من الجدول

110 Dim col As Integer

120 For col = 1 To 10

130 sheet.Cells(1, col + 1).Value = col

140 Next col

'ملئ خلايا الجدول

150 For row = 1 To 10

160 For col = 1 To 10

170 sheet.Cells(row + 1, col + 1).Value = row * col

180 Next col

190 Next row

'تغيير الألوان

200 sheet.Range("A1", "K1").Interior.Color = &HC0C000

210 sheet.Range("A1", "A11").Interior.Color = &HC0C000

220 sheet.Range("B2", "K11").Interior.Color = &HFFC0C0

'ضبط العمود الأيسر والأعلي علي الخط الغامق

230 sheet.Range("A1", "K1").Font.Bold = True

240 sheet.Range("A1", "A11").Font.Bold = True

'جعل تطبيق اكسل مرئيا

250 app.Visible = True

260 sheet.SaveAs "c:\test.xls"

 

End Sub

 

 سوف يكون الناتج كما يلي :

 

 

التعامل من داخل فيجوال بيسك مع برامج التطبيقات

مشروع :

ابدأ مشروع جديد ، وضع عليه 6 أزرار أوامر } Command Buttons كما يلي :

 

 

غير الخاصية Caption  لأزرار الأوامر كما يلي :

 

القيمة

الخاصية

الزر

برنامج إكسل Excel

Caption

Command1

True

RightToLeft

 

Arabic Transparent

Size =12

Font

 

برنامج ورد Word

Caption

Command2

Arabic Transparent

Size =12

Font

 

True

RightToLeft

 

فتح صفحة عمل جديدة

Caption

Command3

Arabic Transparent

Size =12

Font

 

True

RightToLeft

 

فتح وثيقة جديدة

Caption

Command4

Arabic Transparent

Size =12

Font

 

True

RightToLeft

 

إنها صفحة العمل الجديدة

Caption

Command5

Arabic Transparent

Size =12

Font

 

True

RightToLeft

 

إنهاء الوثيقة الجديدة

Caption

Command6

Arabic Transparent

Size =12

Font

 

True

RightToLeft

 

حساب قيمة تعبير رياضي

Caption

Command7

Arabic Transparent

Size =12

Font

 

True

RightToLeft

 

خروج

Caption

Command8

Arabic Transparent

Size =12

Font

 

 

وسوف تبدو نافذة المشروع كما يلي :

 

 

 

Option Explicit

Dim AppWord As Word.Application

Dim AppExcel As Excel.Application

 

 

Private Sub Command1_Click()

 

    Screen.MousePointer = vbHourglass

    Set AppExcel = CreateObject("Excel.Application")

    Screen.MousePointer = vbDefault

    Command3.Enabled = True

    Command5.Enabled = True

    Command8.Enabled = True

   

End Sub

 

Private Sub Command2_Click()

 

    Screen.MousePointer = vbHourglass

    Set AppWord = CreateObject("Word.Application")

    Screen.MousePointer = vbDefault

    Command4.Enabled = True

    Command6.Enabled = True

   

End Sub

 

 

Private Sub Command3_Click()

Dim wSheet As Worksheet

Dim wBook As Workbook

 

    If AppExcel.Workbooks.Count = 0 Then

        Debug.Print "إضافة ورقة عمل جديدة"

        Set wBook = AppExcel.Workbooks.Add

    End If

    Set wSheet = AppExcel.Sheets(1)

    wSheet.Cells(2, 1).Value = "الربع الأول"

    wSheet.Cells(2, 2).Value = "الربع الثاني"

    wSheet.Cells(2, 3).Value = "الربع الثالث"

    wSheet.Cells(2, 4).Value = "الربع الرابع"

    wSheet.Cells(3, 1).Value = 123.45

    wSheet.Cells(3, 2).Value = 435.56

    wSheet.Cells(3, 3).Value = 376.25

    wSheet.Cells(3, 4).Value = 425.75

 

    Range("A2:D2").Select

    With Selection.Font

        .Name = "Verdana"

        .FontStyle = "Bold"

        .Size = 12

    End With

   

    Range("A3:D3").Select

    With Selection.Font

        .Name = "Arabic Transparent"

        .FontStyle = "Regular"

        .Size = 11

    End With

   

    Range("A2:D2").Select

    Selection.Columns.AutoFit

    Selection.ColumnWidth = Selection.ColumnWidth * 1.25

    Range("A2:E2").Select

    With Selection

        .HorizontalAlignment = xlCenter

    End With

 

    AppExcel.Visible = True

   

End Sub

 

Private Sub Command4_Click()

Dim wDoc As Document

Dim tmpText As String

Dim parCount As Long, wordCount As Long, charCount As Long

Dim msg As String

 

    If AppWord.Documents.Count = 0 Then

        AppWord.Documents.Add

    End If

    AppWord.Documents(1).Range.InsertAfter "عنوان الوثيقة" & vbCr

    AppWord.Documents(1).Range.Font.Bold = True

    AppWord.Documents(1).Range.Font.Size = 16

    AppWord.Documents(1).Range.Font.Name = "Arabic Transparent"

    AppWord.Documents(1).Range.InsertAfter "هذه الوثيقة تمثل أول فقرة في الوثيقة وهي منسقة من اليسار فقط" & vbCr

    AppWord.Documents(1).Range.InsertAfter "وهذه هي الفقرة الثانية من الوثيقة "

    AppWord.Documents(1).Range.InsertAfter "وتم إدخالها بالجملة التالية : "

    AppWord.Documents(1).Range.InsertAfter "AppWord.Documents(1).Range.InsertAfter " & vbCr

    AppWord.Documents(1).Range.InsertAfter "والفقرة منسقة من جهة اليسار أيضاً" & vbCrLf

    

    parCount = AppWord.Documents(1).Paragraphs.Count

    wordCount = AppWord.Documents(1).Words.Count

    charCount = AppWord.Documents(1).Characters.Count

    msg = "هذه الوثيقة تحوي " & vbCrLf

    msg = msg & parCount & " فقرات" & vbCrLf

    msg = msg & wordCount & " كلمات" & vbCrLf

    msg = msg & charCount & " حروف"

    MsgBox msg

                Debug.Print "إضافة وثيقة جديدة"

    AppWord.Visible = True

    AppWord.Documents(1).Paragraphs(1).Alignment = wdAlignParagraphCenter

   

End Sub

 

Private Sub Command5_Click()

    AppExcel.DisplayAlerts = False

    AppExcel.Quit

    Command3.Enabled = False

    Command5.Enabled = False

    Command8.Enabled = False

End Sub

 

Private Sub Command6_Click()

   

    On Error Resume Next

    AppWord.DisplayAlerts = False

    AppWord.Quit

Dim wRunning As String

    wRunning = AppWord.Application.Name

    If Error Then

        Command4.Enabled = False

        Command6.Enabled = False

    End If

End Sub

 

Private Sub Command7_Click()

    End

End Sub

 

Private Sub Command8_Click()

Dim wSheet As Worksheet

Dim wBook As Workbook

Dim expression

   

    expression = InputBox("أدخل تعبير رياضي لحسابه   (i.e., 1/cos(3.45)*log(19.004)")

    If Trim(expression) <> "" Then

        If AppExcel.Workbooks.Count = 0 Then

            Debug.Print "إضافة ورقة عمل جديدة"

            Set wBook = AppExcel.Workbooks.Add

        End If

        Set wSheet = AppExcel.Sheets(1)

        On Error GoTo CalcError

        wSheet.Cells(1, 1).Value = "=" & expression

        wSheet.Calculate

        MsgBox "قيمة التعبير  " & expression & vbCrLf & " هي " & wSheet.Cells(1, 1).Value

    End If

    Exit Sub

 

CalcError:

    MsgBox "خطأ في حساب التعبير الرياضي"

End Sub

 

Private Sub Form_Terminate()

    Set AppExcel = Nothing

    Set AppWord = Nothing

End Sub

 

مقدمة :

فرونت بيج FrontPage

فيجوال بيسك وورد Word :

مزيد من ماكروات Macros ورد Word :

إكسل Excel

التعامل من داخل فيجوال بيسك مع برامج التطبيقات

 

صفحة البداية

 

صفحة التطبيقات

 

أعلي الصفحة

 



1 PC Magazine ,vol 5,Issue 6,1999 (Arabic version) ,Page 82