TPE
Tavvafi@gmail.com |
≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡
همانطور که در بدنه اصلی شرح نرم افزار حفاظت از فایل های پاورپوینت توضیح داده شد،کاربرد کدهای ماکرو گاهی به منظور استفاده از آنها هنگام اجرا و نمایش پاورپوینت است،
گاهی نیز به منظور سازماندهی سریعتر بر اساس منطقی خاص است که در این بخش به این نوع برنامه نویسی خواهیم پرداخت.
Sub MakeLotsOfLinks() Dim TheTextBox As Shape Dim FileName As String Dim LinkRange As TextRange Dim Top, Left, width, height As Double Dim targetFileSpec As String ' EDIT THIS: Replace the text between the equals signs ' with the path to the folder where your PPT files are stored targetFileSpec = "D:\Test\*.PPT" ' Rather arbitrary starting positions for text box Top = 18# Left = 18# width = 600# height = 30# ' Get the first matching file FileName = Dir$(targetFileSpec) ' And if somebody's home: While FileName <> "" ' Add a textbox to hold the link Set TheTextBox = ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(msoTextOrientationHorizontal, _ Left, _ Top, _ width, _ height) TheTextBox.TextFrame.TextRange.Text = FileName Set LinkRange = TheTextBox.TextFrame.TextRange.Characters(Start:=1, Length:=Len(FileName)) LinkRange.ActionSettings(ppMouseClick).Hyperlink.Address = FileName ' Get the next file FileName = Dir$ ' move the text box start position down Top = Top + height Wend End Sub
اگر ترجیح می دهید حدولی از لینکها داشته باشید، می توانید از کد زیر استفاده کنید.
ابتدا یک جدول با سلول های شماره دار که می خواهید نام فایل ها و لینک آنها در آن باشد بسازید، بعد جدول را انتخاب کنید و کد زیر را اجرا کنید.
Sub MakeLotsOfLinksInATable() Dim FileName As String Dim LinkRange As TextRange Dim targetFileSpec As String Dim aFileNames() As String Dim oTable As Shape Dim x As Long Dim y As Long Dim lPointer As Long ' EDIT THIS: Replace the text between the equals signs ' with the path to the folder where your PPT files are stored targetFileSpec = "c:\myfiles\*.PPT" ReDim aFileNames(1 To 1) As String ' Fill the array with filenames FileName = Dir$(targetFileSpec) ' And if files are found: While FileName <> "" aFileNames(UBound(aFileNames)) = FileName FileName = Dir$ ReDim Preserve aFileNames(1 To UBound(aFileNames) + 1) As String Wend ' that leaves us with blank array entry; remove it: ReDim Preserve aFileNames(1 To UBound(aFileNames) - 1) As String ' now use the table Set oTable = ActiveWindow.Selection.ShapeRange(1) lPointer = 1 For y = 1 To oTable.Table.Rows.Count For x = 1 To oTable.Table.Columns.Count oTable.Table.Cell(y, x).Shape.TextFrame.TextRange.Text = aFileNames(lPointer) Set LinkRange = _ oTable.Table.Cell(y, x).Shape.TextFrame.TextRange.Characters(Start:=1, Length:=Len(aFileNames(lPointer))) LinkRange.ActionSettings(ppMouseClick).Hyperlink.Address = aFileNames(lPointer) lPointer = lPointer + 1 Next ' x Next ' y End Sub