概要
今回は、Power Point のCustom User Interface を作成し、VBAで、次の３つの処理を実行します。
① 起動時にテキストボックス・図形・線の既定色等を設定
② editBox入力値から、データ検索・結果を表示する処理
③ メニューボタン選択により、図形の色・透明度等を変更
②③処理は下記動画にて概要を確認します。メッセージボックス，選択ボタン等がキャプチャー出来ていないので、かなり判りにくいと思いますが、ご容赦下さい。
XML編集
作成したCUSTOM UI は下図です。
このCUSTOM UIを形成するXMLは次の通りです。
OFFICE-CUSTOM-UI-EDITORで編集します。
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" onLoad="onLoad">
<ribbon startFromScratch="false">
<tabs>
<tab id="tab00" visible="true" label="MyCustomTab" >
<group id="grp01" label="名前から電話番号を検索する風のデモ">
<box id="box01" boxStyle="vertical">
<box id="box02">
<editBox id="editBox01" label="氏名" imageMso="CondolatoryEvent" maxLength="12" sizeString="WWWWWMMMMMWW" getText="getText" onChange="onChange" />
</box>
<box id="box03">
<editBox id="editBox02" label="電話" imageMso="AutoDial" maxLength="4" sizeString="WWWW" getText="getText" onChange="onChange" />
<editBox id="editBox03" maxLength="4" sizeString="WWWW" getText="getText" onChange="onChange" />
<editBox id="editBox04" maxLength="4" sizeString="WWWW" getText="getText" onChange="onChange" />
</box>
</box>
<separator id="separator01" />
<button id="btn01" label="電話番号検索" imageMso="HappyFace" size="large" onAction="onAction" />
</group>
<group id="grp02" label="色設定" >
<menu id="menu01" itemSize="large" size="large" getLabel="getLabel" getImage="getImage" >
<button id="btn02" tag="0" onAction="get_color" label="aqua" image="j_aqua" />
<button id="btn03" tag="1" onAction="get_color" label="black" image="j_black" />
<button id="btn04" tag="2" onAction="get_color" label="blue" image="j_blue" />
<button id="btn05" tag="3" onAction="get_color" label="fuchsia" image="j_fuchsia" />
<button id="btn06" tag="4" onAction="get_color" label="lime" image="j_lime" />
<button id="btn07" tag="5" onAction="get_color" label="red" image="j_red" />
<button id="btn08" tag="6" onAction="get_color" label="yellow" image="j_yellow" />
</menu>
<menu id="menu02" itemSize="large" size="large" getLabel="getLbl_transparency" imageMso="BehindText" >
<button id="btn10" tag="0" onAction="set_transparency" label="0%" image="tp_0" />
<button id="btn11" tag="20" onAction="set_transparency" label="20%" image="tp_20" />
<button id="btn12" tag="40" onAction="set_transparency" label="40%" image="tp_40" />
<button id="btn13" tag="60" onAction="set_transparency" label="60%" image="tp_60" />
<button id="btn14" tag="80" onAction="set_transparency" label="80%" image="tp_80" />
</menu>
<menu id="menu03" itemSize="large" size="large" getLabel="getLbl_selectTaget" getImage="getImageTgt" >
<button id="btn15" tag="0" onAction="set_target_object_type" label="line" image="select_line" />
<button id="btn16" tag="1" onAction="set_target_object_type" label="shape" image="select_shape" />
</menu>
</group>
</tab>
</tabs>
</ribbon>
</customUI>
２０行目の「 imageMso=”HappyFace” 」 と記載することで、表示するアイコン画像を指定します。 imageMso はマイクロソフトOFFICEの組み込み画像で、 “HappyFace”は黄色のスマイル画像を特定するものです。 OFFICEバージョンによって使用できるアイコンは多少違いがある様です。
マイクロソフト公式サイトでアイコンリストを探しましたが、見つけられませんでした。公式ではありませんが、一覧表を公開されているHPがありますので活用させて頂きました。
一方、次の図の通り自分で用意したカスタムアイコンを使用することもできます。「Insert Icons」をクリックし対象画像ファイルを取り込みます。アイコン画像は 32X32 (pixel)にしています。
XMLでは、「 image=”j_aqua”」の様に対象アイコン画像を指定しています。
図形・他の既定色等を設定
PowerPoint を普通に起動し、図形・テキストボックス等を挿入すると下図の左側の様になります。文字フォント・色等の規定値を標準設定する方法があるのかもしれませんが、判りませんでしたのでVBAで初期設定することにしました。下図の右側が設定例です。文字フォント・色 以外にも 枠線の太さ・文字サイズ・透明性等を初期設定出来ます。
XML ２行目の onLoad=”onLoad” は、読込時に実行する関数を定義しています。
XMLで定義した読み込み時に最初に実行される “onLoad” 関数をVBA側で次の様に設定し、更に “add_shape_default_set” を呼び出します。ここで既定値を設定しています。
手順は人同様です。スライド追加、テキストボックス配置後、文字位置・マージン・文字サイズ・フォント・文字色・塗り潰し色・枠線色等を設定します。次に “ SetShapesDefaultProperties ” を実行し、規定値として設定します。
同様に図形（shape）, 直線（line）を追加、必要項目設定後、それぞれ既定値設定します。最後にスライドを抹消し、初期設定を終えます。
'◆◆◆◆◆ 起動時初期設定 ◆◆◆◆◆
Sub onLoad(ribbon As IRibbonUI)
Call add_shape_default_set '追加SHAPEのデフォルト設定
End Sub
Public Sub add_shape_default_set()
Dim act_prs As Presentation
Dim sld As Slide
Dim txt As Shape
Set act_prs = ActivePresentation
Set sld = act_prs.Slides.Add(Index:=1, Layout:=ppLayoutText)
Set txt = sld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=50, Top:=50, Width:=120, Height:=40)
txt.Name = "AddedTextBox"
txt.TextFrame.TextRange = "サンプル"
txt.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
txt.TextFrame.VerticalAnchor = msoAnchorMiddle
txt.TextFrame.MarginLeft = 0
txt.TextFrame.MarginRight = 0
txt.TextFrame.MarginTop = 0
txt.TextFrame.MarginBottom = 0
txt.TextFrame.AutoSize = ppAutoSizeNone
txt.TextEffect.FontSize = 20
txt.TextEffect.FontBold = msoTrue
txt.TextFrame.TextRange.Font.Name = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameComplexScript = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameFarEast = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0) '文字色
txt.Fill.Visible = msoTrue
txt.Fill.ForeColor.RGB = RGB(255, 255, 220) 'ボックス内部色（薄黄色）
txt.Line.Visible = msoTrue
txt.Line.Weight = 2
txt.Line.ForeColor.RGB = RGB(0, 0, 255) '枠線色（青）
txt.SetShapesDefaultProperties 'デフォルトプロパティに設定
Set txt = sld.Shapes.AddLine(BeginX:=100, BeginY:=100, EndX:=200, EndY:=200)
txt.Line.ForeColor.RGB = RGB(255, 0, 0) '直線色
txt.Line.Weight = 3
txt.SetShapesDefaultProperties 'デフォルトプロパティに設定
Set txt = sld.Shapes.AddShape(Type:=msoShapeRectangle, Top:=70, Left:=200, Width:=100, Height:=120)
txt.Fill.ForeColor.RGB = RGB(255, 255, 220) 'ボックス内部色（薄黄色）
txt.Line.Weight = 2
txt.Line.ForeColor.RGB = RGB(0, 0, 255) '枠線色（青）
txt.TextFrame.TextRange = "サンプル"
txt.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
txt.TextFrame.VerticalAnchor = msoAnchorMiddle
txt.TextFrame.MarginLeft = 0
txt.TextFrame.MarginRight = 0
txt.TextFrame.MarginTop = 0
txt.TextFrame.MarginBottom = 0
txt.TextFrame.AutoSize = ppAutoSizeNone
txt.TextEffect.FontSize = 20
txt.TextEffect.FontBold = msoTrue
txt.TextFrame.TextRange.Font.Name = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameComplexScript = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameFarEast = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0) '文字色
txt.SetShapesDefaultProperties 'デフォルトプロパティに設定
sld.Select
sld.Delete
End Sub
editBox入力値についてデータ検索
次は「電話番号検索」ボタンクリック時に、氏名に入力されている名前から、電話番号を検索し表示するデモです。
実際にはデータ検索は行っていませんが、“田中”さん，“鈴木”さんが入力されている場合は電話番号を表示し、それ以外の人の場合は電話番号は消去されます。
プログラムは、次の通りです。
Option Explicit
Private rbn_ui As IRibbonUI 'リボン
Private edtTxt01 As String 'editBox文字列
Private edtTxt02 As String 'editBox文字列
Private edtTxt03 As String 'editBox文字列
Private edtTxt04 As String 'editBox文字列
'◆◆◆◆◆ 起動時初期設定 ◆◆◆◆◆
Sub onLoad(ribbon As IRibbonUI)
Set rbn_ui = ribbon
edtTxt01 = "": edtTxt02 = "": edtTxt03 = "": edtTxt04 = ""
rbn_ui.Invalidate 'リボン表示更新
End Sub
'◆◆◆◆◆ 検索デモ ◆◆◆◆◆
'コントロールテキスト取得
Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
Dim rtn_tmp
rtn_tmp = ""
If control.Id = "editBox01" Then rtn_tmp = edtTxt01
If control.Id = "editBox02" Then rtn_tmp = edtTxt02
If control.Id = "editBox03" Then rtn_tmp = edtTxt03
If control.Id = "editBox04" Then rtn_tmp = edtTxt04
returnedVal = rtn_tmp
End Sub
'コントール変化時に値取得 （editBoxで[Enter]入力、他コントロール移動時イベント）
Sub onChange(control As IRibbonControl, text As String)
If control.Id = "editBox01" Then edtTxt01 = text
End Sub
'検索処理想定
Sub onAction(control As IRibbonControl)
Dim name_input
name_input = StrConv(StrConv(Trim(edtTxt01), 1), 8)
If name_input = "" Then
MsgBox "氏名が未入力です。処理を中断します。", vbOKOnly + vbExclamation, "氏名未設定エラー"
edtTxt02 = "": edtTxt03 = "": edtTxt04 = ""
ElseIf Left(name_input, 2) = "鈴木" Then
MsgBox "鈴木さんの電話番号を確認しました。", vbOKOnly + vbInformation, "電話番号確認！"
edtTxt02 = "012": edtTxt03 = "345": edtTxt04 = "6789"
ElseIf Left(name_input, 2) = "田中" Then
MsgBox "田中さんの電話番号を確認しました。", vbOKOnly + vbInformation, "電話番号確認！"
edtTxt02 = "9999": edtTxt03 = "8765": edtTxt04 = "4321"
Else
MsgBox "知らない人です。処理を中断します。", vbOKOnly + vbExclamation, "知らない人です。"
edtTxt02 = "": edtTxt03 = "": edtTxt04 = ""
End If
rbn_ui.InvalidateControl ("editBox02")
rbn_ui.InvalidateControl ("editBox03")
rbn_ui.InvalidateControl ("editBox04")
End Sub
図形の色・透明度等を変更
選択したテキストボックス・図形・直線等の色と透明度を設定します。動画ではキャプチャーできていませんが、実際には下図の通りメニューボタン選択時に色・透明度を設定します。複数選択にも対応しています。
最右の line / shape 選択は、テキストボックス・図形の場合、lineは枠線，shapeは内部塗りつぶしを行います。直線の場合、line は有効ですが、shape は無効です。
プログラムは次の通りです。
Option Explicit
Private rbn_ui As IRibbonUI 'リボン
Private color_name 'ﾃｷｽﾄﾎﾞｯｸｽ・shape塗り潰し色設定
Private trans_parency 'ﾃｷｽﾄﾎﾞｯｸｽ・shape透明度設定
Private tgt_type 'ﾃｷｽﾄﾎﾞｯｸｽ・shape透明度設定
'◆◆◆◆◆ 起動時初期設定 ◆◆◆◆◆
Sub onLoad(ribbon As IRibbonUI)
color_name = "black"
trans_parency = "0%"
tgt_type = "shape"
Set rbn_ui = ribbon
rbn_ui.Invalidate 'リボン表示更新
End Sub
'◆◆◆◆◆ 塗り潰し色を設定する ◆◆◆◆◆
'外部画像ファイルを取得設定する
Sub getImage(control As IRibbonControl, ByRef img)
Set img = LoadPicture(ActivePresentation.Path & "\color_sample\j_" & color_name & ".jpg")
'Set img = LoadImage(ActivePresentation.Path & "\color_sample\png_" & color_name & ".png")
End Sub
'表示ラベル取得
Sub getLabel(control As IRibbonControl, ByRef lbl)
lbl = color_name
End Sub
'shape・textBoxに選択色設定
Sub get_color(control As IRibbonControl)
Dim color_no
color_no = control.Tag
color_name = "black"
If color_no = "0" Then color_name = "aqua"
If color_no = "1" Then color_name = "black"
If color_no = "2" Then color_name = "blue"
If color_no = "3" Then color_name = "fuchsia"
If color_no = "4" Then color_name = "lime"
If color_no = "5" Then color_name = "red"
If color_no = "6" Then color_name = "yellow"
Call change_color_selected_item
rbn_ui.InvalidateControl ("menu01")
End Sub
'選択色に対応する色を実際にShapeに設定する
Private Sub change_color_selected_item()
Dim shp As Shape
Dim ck1, ck2
Dim chk_selected
Dim trs_parency_val
With ActiveWindow.Selection
If .Type = ppSelectionNone Then Exit Sub '未選択
If .Type = ppSelectionSlides Then Exit Sub 'スライド選択
'If .Type = ppSelectionShapes Then Stop 'Shape選択
'If .Type = ppSelectionText Then Stop '文字選択
For Each shp In .ShapeRange
chk_selected = 0
ck1 = shp.Type
ck2 = shp.AutoShapeType
trs_parency_val = Val(Replace(trans_parency, "%", ""))
If trs_parency_val > 0 Then trs_parency_val = trs_parency_val / 100
If tgt_type = "shape" Then
'図形(shape)に色をつける
If ck1 <> msoAutoShape And ck1 <> msoCallout And ck1 <> msoTextBox Then chk_selected = 1
If ck2 <= 0 Then chk_selected = 2
If chk_selected = 0 Then
If color_name = "aqua" Then shp.Fill.ForeColor.RGB = RGB(0, 255, 255)
If color_name = "black" Then shp.Fill.ForeColor.RGB = RGB(0, 0, 0)
If color_name = "blue" Then shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
If color_name = "fuchsia" Then shp.Fill.ForeColor.RGB = RGB(255, 0, 255)
If color_name = "lime" Then shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
If color_name = "red" Then shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
If color_name = "yellow" Then shp.Fill.ForeColor.RGB = RGB(255, 255, 0)
shp.Fill.Transparency = trs_parency_val
End If
ElseIf tgt_type = "line" Then
'線に色をつける
If color_name = "aqua" Then shp.Line.ForeColor.RGB = RGB(0, 255, 255)
If color_name = "black" Then shp.Line.ForeColor.RGB = RGB(0, 0, 0)
If color_name = "blue" Then shp.Line.ForeColor.RGB = RGB(0, 0, 255)
If color_name = "fuchsia" Then shp.Line.ForeColor.RGB = RGB(255, 0, 255)
If color_name = "lime" Then shp.Line.ForeColor.RGB = RGB(0, 255, 0)
If color_name = "red" Then shp.Line.ForeColor.RGB = RGB(255, 0, 0)
If color_name = "yellow" Then shp.Line.ForeColor.RGB = RGB(255, 255, 0)
If ck1 <> msoInkComment Then
shp.Line.Transparency = trs_parency_val
End If
End If
Next shp
End With
End Sub
'◆◆◆◆◆ 塗り潰し透明度を設定する ◆◆◆◆◆
'透明度ラベル設定
Sub getLbl_transparency(control As IRibbonControl, ByRef lbl)
lbl = trans_parency
End Sub
'透明度を設定する
Sub set_transparency(control As IRibbonControl)
Dim select_tag_no
select_tag_no = control.Tag
trans_parency = "0%"
If select_tag_no = "0" Then trans_parency = "0%"
If select_tag_no = "20" Then trans_parency = "20%"
If select_tag_no = "40" Then trans_parency = "40%"
If select_tag_no = "60" Then trans_parency = "60%"
If select_tag_no = "80" Then trans_parency = "80%"
Call change_color_selected_item
rbn_ui.InvalidateControl ("menu02")
End Sub
'◆◆◆◆◆ 線 もしくは、図形かを設定 ◆◆◆◆◆
'外部画像ファイルを取得設定する
Sub getImageTgt(control As IRibbonControl, ByRef img)
Set img = LoadPicture(ActivePresentation.Path & "\color_sample\select_" & tgt_type & ".jpg")
'Set img = LoadImage(ActivePresentation.Path & "\color_sample\png_" & color_name & ".png")
End Sub
'表示ラベル取得
Sub getLbl_selectTaget(control As IRibbonControl, ByRef lbl)
lbl = tgt_type
End Sub
'shape・textBoxに選択色設定
Sub set_target_object_type(control As IRibbonControl)
Dim shp_type
shp_type = control.Tag
tgt_type = "shape"
If shp_type = "0" Then tgt_type = "line"
If shp_type = "1" Then tgt_type = "shape"
Call change_color_selected_item
rbn_ui.InvalidateControl ("menu03")
End Sub
まとめ
気になったことを幾つか整理しておきます。
- editBox が大きく表示出来るとより良い。
- テキストボックス編集時、ホームタブに移動してしまう。
- メニューボタンのアイコン画像変更時に外部画像ファイルを読み込むが png ファイルは利用できない。 予めインポートした画像を利用できると良い・・・。
VBAプログラム全体です。
Option Explicit
Private rbn_ui As IRibbonUI 'リボン
Private edtTxt01 As String 'editBox文字列
Private edtTxt02 As String 'editBox文字列
Private edtTxt03 As String 'editBox文字列
Private edtTxt04 As String 'editBox文字列
Private color_name 'ﾃｷｽﾄﾎﾞｯｸｽ・shape塗り潰し色設定
Private trans_parency 'ﾃｷｽﾄﾎﾞｯｸｽ・shape透明度設定
Private tgt_type 'ﾃｷｽﾄﾎﾞｯｸｽ・shape透明度設定
'◆◆◆◆◆ 起動時初期設定 ◆◆◆◆◆
Sub onLoad(ribbon As IRibbonUI)
color_name = "black"
trans_parency = "0%"
tgt_type = "shape"
Set rbn_ui = ribbon
edtTxt01 = "": edtTxt02 = "": edtTxt03 = "": edtTxt04 = ""
rbn_ui.Invalidate 'リボン表示更新
Call add_shape_default_set '追加SHAPEのデフォルト設定
End Sub
'◆◆◆◆◆ 検索デモ ◆◆◆◆◆
'コントロールテキスト取得
Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
Dim rtn_tmp
rtn_tmp = ""
If control.Id = "editBox01" Then rtn_tmp = edtTxt01
If control.Id = "editBox02" Then rtn_tmp = edtTxt02
If control.Id = "editBox03" Then rtn_tmp = edtTxt03
If control.Id = "editBox04" Then rtn_tmp = edtTxt04
returnedVal = rtn_tmp
End Sub
'コントール変化時に値取得 （editBoxで[Enter]入力、他コントロール移動時イベント）
Sub onChange(control As IRibbonControl, text As String)
If control.Id = "editBox01" Then edtTxt01 = text
End Sub
'検索処理想定
Sub onAction(control As IRibbonControl)
Dim name_input
name_input = StrConv(StrConv(Trim(edtTxt01), 1), 8)
If name_input = "" Then
MsgBox "氏名が未入力です。処理を中断します。", vbOKOnly + vbExclamation, "氏名未設定エラー"
edtTxt02 = "": edtTxt03 = "": edtTxt04 = ""
ElseIf Left(name_input, 2) = "鈴木" Then
MsgBox "鈴木さんの電話番号を確認しました。", vbOKOnly + vbInformation, "電話番号確認！"
edtTxt02 = "012": edtTxt03 = "345": edtTxt04 = "6789"
ElseIf Left(name_input, 2) = "田中" Then
MsgBox "田中さんの電話番号を確認しました。", vbOKOnly + vbInformation, "電話番号確認！"
edtTxt02 = "9999": edtTxt03 = "8765": edtTxt04 = "4321"
Else
MsgBox "知らない人です。処理を中断します。", vbOKOnly + vbExclamation, "知らない人です。"
edtTxt02 = "": edtTxt03 = "": edtTxt04 = ""
End If
rbn_ui.InvalidateControl ("editBox02")
rbn_ui.InvalidateControl ("editBox03")
rbn_ui.InvalidateControl ("editBox04")
End Sub
'◆◆◆◆◆ 塗り潰し色を設定する ◆◆◆◆◆
'外部画像ファイルを取得設定する
Sub getImage(control As IRibbonControl, ByRef img)
Set img = LoadPicture(ActivePresentation.Path & "\color_sample\j_" & color_name & ".jpg")
'Set img = LoadImage(ActivePresentation.Path & "\color_sample\png_" & color_name & ".png")
End Sub
'表示ラベル取得
Sub getLabel(control As IRibbonControl, ByRef lbl)
lbl = color_name
End Sub
'shape・textBoxに選択色設定
Sub get_color(control As IRibbonControl)
Dim color_no
color_no = control.Tag
color_name = "black"
If color_no = "0" Then color_name = "aqua"
If color_no = "1" Then color_name = "black"
If color_no = "2" Then color_name = "blue"
If color_no = "3" Then color_name = "fuchsia"
If color_no = "4" Then color_name = "lime"
If color_no = "5" Then color_name = "red"
If color_no = "6" Then color_name = "yellow"
Call change_color_selected_item
rbn_ui.InvalidateControl ("menu01")
End Sub
'選択色に対応する色を実際にShapeに設定する
Private Sub change_color_selected_item()
Dim shp As Shape
Dim ck1, ck2
Dim chk_selected
Dim trs_parency_val
With ActiveWindow.Selection
If .Type = ppSelectionNone Then Exit Sub '未選択
If .Type = ppSelectionSlides Then Exit Sub 'スライド選択
'If .Type = ppSelectionShapes Then Stop 'Shape選択
'If .Type = ppSelectionText Then Stop '文字選択
For Each shp In .ShapeRange
chk_selected = 0
ck1 = shp.Type
ck2 = shp.AutoShapeType
trs_parency_val = Val(Replace(trans_parency, "%", ""))
If trs_parency_val > 0 Then trs_parency_val = trs_parency_val / 100
If tgt_type = "shape" Then
'図形(shape)に色をつける
If ck1 <> msoAutoShape And ck1 <> msoCallout And ck1 <> msoTextBox Then chk_selected = 1
If ck2 <= 0 Then chk_selected = 2
If chk_selected = 0 Then
If color_name = "aqua" Then shp.Fill.ForeColor.RGB = RGB(0, 255, 255)
If color_name = "black" Then shp.Fill.ForeColor.RGB = RGB(0, 0, 0)
If color_name = "blue" Then shp.Fill.ForeColor.RGB = RGB(0, 0, 255)
If color_name = "fuchsia" Then shp.Fill.ForeColor.RGB = RGB(255, 0, 255)
If color_name = "lime" Then shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
If color_name = "red" Then shp.Fill.ForeColor.RGB = RGB(255, 0, 0)
If color_name = "yellow" Then shp.Fill.ForeColor.RGB = RGB(255, 255, 0)
shp.Fill.Transparency = trs_parency_val
End If
ElseIf tgt_type = "line" Then
'線に色をつける
If color_name = "aqua" Then shp.Line.ForeColor.RGB = RGB(0, 255, 255)
If color_name = "black" Then shp.Line.ForeColor.RGB = RGB(0, 0, 0)
If color_name = "blue" Then shp.Line.ForeColor.RGB = RGB(0, 0, 255)
If color_name = "fuchsia" Then shp.Line.ForeColor.RGB = RGB(255, 0, 255)
If color_name = "lime" Then shp.Line.ForeColor.RGB = RGB(0, 255, 0)
If color_name = "red" Then shp.Line.ForeColor.RGB = RGB(255, 0, 0)
If color_name = "yellow" Then shp.Line.ForeColor.RGB = RGB(255, 255, 0)
If ck1 <> msoInkComment Then
shp.Line.Transparency = trs_parency_val
End If
End If
Next shp
End With
End Sub
'◆◆◆◆◆ 塗り潰し透明度を設定する ◆◆◆◆◆
'透明度ラベル設定
Sub getLbl_transparency(control As IRibbonControl, ByRef lbl)
lbl = trans_parency
End Sub
'透明度を設定する
Sub set_transparency(control As IRibbonControl)
Dim select_tag_no
select_tag_no = control.Tag
trans_parency = "0%"
If select_tag_no = "0" Then trans_parency = "0%"
If select_tag_no = "20" Then trans_parency = "20%"
If select_tag_no = "40" Then trans_parency = "40%"
If select_tag_no = "60" Then trans_parency = "60%"
If select_tag_no = "80" Then trans_parency = "80%"
Call change_color_selected_item
rbn_ui.InvalidateControl ("menu02")
End Sub
'◆◆◆◆◆ 線 もしくは、図形かを設定 ◆◆◆◆◆
'外部画像ファイルを取得設定する
Sub getImageTgt(control As IRibbonControl, ByRef img)
Set img = LoadPicture(ActivePresentation.Path & "\color_sample\select_" & tgt_type & ".jpg")
'Set img = LoadImage(ActivePresentation.Path & "\color_sample\png_" & color_name & ".png")
End Sub
'表示ラベル取得
Sub getLbl_selectTaget(control As IRibbonControl, ByRef lbl)
lbl = tgt_type
End Sub
'shape・textBoxに選択色設定
Sub set_target_object_type(control As IRibbonControl)
Dim shp_type
shp_type = control.Tag
tgt_type = "shape"
If shp_type = "0" Then tgt_type = "line"
If shp_type = "1" Then tgt_type = "shape"
Call change_color_selected_item
rbn_ui.InvalidateControl ("menu03")
End Sub
'SHAPE等の初期設定する
Public Sub add_shape_default_set()
Dim act_prs As Presentation
Dim sld As Slide
Dim txt As Shape
Set act_prs = ActivePresentation
Set sld = act_prs.Slides.Add(Index:=1, Layout:=ppLayoutText)
Set txt = sld.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=50, Top:=50, Width:=120, Height:=40)
txt.Name = "AddedTextBox"
txt.TextFrame.TextRange = "サンプル"
txt.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
txt.TextFrame.VerticalAnchor = msoAnchorMiddle
txt.TextFrame.MarginLeft = 0
txt.TextFrame.MarginRight = 0
txt.TextFrame.MarginTop = 0
txt.TextFrame.MarginBottom = 0
txt.TextFrame.AutoSize = ppAutoSizeNone
txt.TextEffect.FontSize = 20
txt.TextEffect.FontBold = msoTrue
txt.TextFrame.TextRange.Font.Name = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameComplexScript = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameFarEast = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0) '文字色
txt.Fill.Visible = msoTrue
txt.Fill.ForeColor.RGB = RGB(255, 255, 220) 'ボックス内部色（薄黄色）
txt.Line.Visible = msoTrue
txt.Line.Weight = 2
txt.Line.ForeColor.RGB = RGB(0, 0, 255) '枠線色（青）
txt.SetShapesDefaultProperties 'デフォルトプロパティに設定
Set txt = sld.Shapes.AddLine(BeginX:=100, BeginY:=100, EndX:=200, EndY:=200)
txt.Line.ForeColor.RGB = RGB(255, 0, 0) '直線色
txt.Line.Weight = 3
txt.SetShapesDefaultProperties 'デフォルトプロパティに設定
Set txt = sld.Shapes.AddShape(Type:=msoShapeRectangle, Top:=70, Left:=200, Width:=100, Height:=120)
txt.Fill.ForeColor.RGB = RGB(255, 255, 220) 'ボックス内部色（薄黄色）
txt.Line.Weight = 2
txt.Line.ForeColor.RGB = RGB(0, 0, 255) '枠線色（青）
txt.TextFrame.TextRange = "サンプル"
txt.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
txt.TextFrame.VerticalAnchor = msoAnchorMiddle
txt.TextFrame.MarginLeft = 0
txt.TextFrame.MarginRight = 0
txt.TextFrame.MarginTop = 0
txt.TextFrame.MarginBottom = 0
txt.TextFrame.AutoSize = ppAutoSizeNone
txt.TextEffect.FontSize = 20
txt.TextEffect.FontBold = msoTrue
txt.TextFrame.TextRange.Font.Name = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameComplexScript = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.NameFarEast = "ＭＳ Ｐゴシック"
txt.TextFrame.TextRange.Font.Color.RGB = RGB(255, 0, 0) '文字色
txt.SetShapesDefaultProperties 'デフォルトプロパティに設定
sld.Select
sld.Delete
End Sub