cuoilennaocacban
Thành viên mới
- Tham gia
- 29/12/08
- Bài viết
- 1
- Được thích
- 0
Mã:
Option Explicit
Option Private Module
Global Const APP_NAME = "Animation Carbon"
Global Const APP_VERSION = "1.0"
Declare Function ShellExecute Lib "Shell32" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As _
Long) As Long
Dim oSPFxSession As Object ' SPFx.cSPFx
Sub InitSession()
Static Initialized As Boolean
On Error Resume Next
If Not oSPFxSession Is Nothing Then
If Initialized Then
oSPFxSession.Show
Else
Call oSPFxSession.CallChildToolbar(Application)
Initialized = True
End If
Else
Set oSPFxSession = Nothing
Set oSPFxSession = CreateObject("SPFx.cSPFx")
If Not oSPFxSession Is Nothing Then
Call oSPFxSession.CallChildToolbar(Application)
Initialized = True
Else
MsgBox "Unable to create session"
End If
End If
End Sub
Sub Auto_Open()
On Error Resume Next
If Val(Application.Version) < 10 Then
MsgBox APP_NAME & " requires PowerPoint 2002 or higher.", vbCritical, APP_NAME
Exit Sub
End If
Dim PCSControl As CommandBarButton
Dim oIconButt As CommandBarControl
Dim IIPopUp As CommandBarPopup
Dim CmdMenu As CommandBars
Call Auto_Close
Set CmdMenu = Application.CommandBars
CmdMenu("View").FindControl(Tag:=APP_NAME & "Popup").Delete
Set IIPopUp = CmdMenu("Tools") _
.Controls.Add(Type:=msoControlPopup, Temporary:=True)
With IIPopUp
.BeginGroup = True
.Caption = "&" & APP_NAME
.Tag = APP_NAME & "Popup"
End With
Set PCSControl = IIPopUp.Controls.Add(Type:=msoControlButton, Temporary:=True)
With PCSControl
.Caption = "&About..."
'.OnAction = Application.AddIns("IIW").Path & "\IIW.ppa!ShowAbout"
.OnAction = "ShowSPFxAbout"
.Tag = APP_NAME & "TagAbout"
.Visible = True
End With
Set PCSControl = IIPopUp.Controls.Add(Type:=msoControlButton, Temporary:=True)
With PCSControl
.BeginGroup = True
.Caption = "&Show " & APP_NAME
.OnAction = "InitSession"
.Tag = APP_NAME & "Window"
.Visible = True
End With
Set PCSControl = IIPopUp.Controls.Add(Type:=msoControlButton, Temporary:=True)
With PCSControl
.Caption = APP_NAME & " Overview"
.OnAction = "LaunchOverview"
.Tag = APP_NAME & "Window"
.Visible = True
End With
Set PCSControl = IIPopUp.Controls.Add(Type:=msoControlButton, Temporary:=True)
With PCSControl
.Caption = APP_NAME & " Help"
.Style = msoButtonIconAndCaption
.OnAction = "LaunchHelp"
.Tag = APP_NAME & "TagHelp"
.Visible = True
.BeginGroup = True
Set oIconButt = CommandBars.FindControl(Type:=msoControlButton, Id:=984)
oIconButt.CopyFace
.PasteFace
End With
Set PCSControl = IIPopUp.Controls.Add(Type:=msoControlButton, Temporary:=True)
With PCSControl
.Caption = APP_NAME & " Home"
.Style = msoButtonIconAndCaption
.OnAction = "LaunchHome"
.Tag = APP_NAME & "TagHelp"
.Visible = True
End With
If GetSetting(APP_NAME, "Options", "FirstRun", "0") = "0" Then
MsgBox "Select Tools | " & APP_NAME & " | Show " & APP_NAME & " to display the dialog. ", vbInformation, APP_NAME
Call SaveSetting(APP_NAME, "Options", "FirstRun", "1")
End If
Call AddSCMenu("Shapes", "Draw")
Call AddSCMenu("OLE Object", "Draw")
Call AddSCMenu("Picture", "Draw")
Call AddSCMenu("WordArt", "Draw")
Call AddSCMenu("Connector", "Draw")
Call AddSCMenu("Curve", "Draw")
Call AddSCMenu("Curve Point", "Draw")
Call AddSCMenu("Curve Segment", "Draw")
Call AddSCMenu("Rotate Mode", "Draw")
Call AddSCMenu("WordArt", "Draw")
Call AddSCMenu("Tables", "Table")
Set CmdMenu = Nothing
On Error GoTo 0
End Sub
Sub ShowSPFxAbout()
If Not oSPFxSession Is Nothing Then
Call oSPFxSession.ShowAbout(Application)
Else
Set oSPFxSession = Nothing
Set oSPFxSession = CreateObject("SPFx.cSPFx")
If Not oSPFxSession Is Nothing Then
Call oSPFxSession.ShowAbout(Application)
Else
MsgBox "Unable to display About dialog.", vbExclamation, APP_NAME
End If
End If
End Sub
Sub Auto_Close()
On Error Resume Next
CommandBars("Tools").FindControl(Tag:=APP_NAME & "Popup").Delete
If Not oSPFxSession Is Nothing Then
oSPFxSession.CloseSession
Set oSPFxSession = Nothing
End If
Call DeleteSCMenu("Shapes", "Draw")
Call DeleteSCMenu("OLE Object", "Draw")
Call DeleteSCMenu("Picture", "Draw")
Call DeleteSCMenu("WordArt", "Draw")
Call DeleteSCMenu("Connector", "Draw")
Call DeleteSCMenu("Curve", "Draw")
Call DeleteSCMenu("Curve Point", "Draw")
Call DeleteSCMenu("Curve Segment", "Draw")
Call DeleteSCMenu("Rotate Mode", "Draw")
Call DeleteSCMenu("WordArt", "Draw")
Call DeleteSCMenu("Tables", "Table")
End Sub
Sub Launch(Path As String)
On Error Resume Next
ShellExecute 0, "Open", Path, "", "", 1
End Sub
Function AppendSeparator(Path As String, Optional ForwardSlash As Boolean = False) As String
Const PATH_SEPARATOR_FORWARD = "/"
Const PATH_SEPARATOR = "\"
If Path = "" Then Exit Function
If Not ForwardSlash Then
AppendSeparator = IIf(Right(Path, 1) = PATH_SEPARATOR, Path, Path & PATH_SEPARATOR)
Else
AppendSeparator = IIf(Right(Path, 1) = PATH_SEPARATOR_FORWARD, Path, Path & PATH_SEPARATOR_FORWARD)
End If
End Function
Sub LaunchHelp()
On Error Resume Next
Call Launch(AppendSeparator(AddIns("animcarbon.ppa").Path) & "animcarbon.chm")
End Sub
Sub LaunchHome()
On Error Resume Next
Call Launch("http://www.mvps.org/skp/ac/index.html")
End Sub
Sub LaunchOverview()
On Error Resume Next
Call Launch(AppendSeparator(AddIns("animcarbon.ppa").Path) & "animation carbon overview\index.html")
End Sub
Sub AddSCMenu(sName As String, Parent As String)
Dim cbCmdBarMenu As CommandBar
Dim cbMenu As CommandBarButton
Dim cbSubMenu As CommandBarPopup
Dim cbSubMenuSM As Object
Set cbCmdBarMenu = Application _
.CommandBars("Shortcut Menus")
Set cbSubMenu = cbCmdBarMenu.Controls(Parent)
Set cbSubMenuSM = cbSubMenu.Controls(sName)
' Add the new menu.
With cbSubMenuSM.Controls
Set cbMenu = _
.Add(Type:=msoControlButton)
With cbMenu
.OnAction = "InitSession"
.Caption = APP_NAME & "..."
End With
End With
End Sub
Sub DeleteSCMenu(sName As String, Parent As String)
On Error Resume Next
Dim cbCmdBarMenu As CommandBar
Dim cbSubMenu As CommandBarPopup
Dim cbSubMenuSM As Object
Set cbCmdBarMenu = Application.CommandBars("Shortcut Menus")
Set cbSubMenu = cbCmdBarMenu.Controls(Parent)
Set cbSubMenuSM = cbSubMenu.Controls(sName)
cbSubMenuSM.Controls(APP_NAME & "...").Delete
End Sub