Skip to content

Instantly share code, notes, and snippets.

@YujiFukami

YujiFukami/OutputSelectShapeToPicture

Created October 29, 2025 08:17
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save YujiFukami/9a661a5d55926aca1eb06becf223d0ce to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save YujiFukami/9a661a5d55926aca1eb06becf223d0ce to your computer and use it in GitHub Desktop.
Download ZIP
Raw
OutputSelectShapeToPicture
'OutputSelectShapeToPicture ・・・元場所：IkiKaiso2.ModRibbon
'GetActiveBookPathOrSelectFolder・・・元場所：IkiKaiso2.ModFile
'SelectFolder ・・・元場所：IkiKaiso2.ModFile
'ConvOneDrivePath_LocalPath ・・・元場所：IkiKaiso2.ModFile
'Get__出力済み画像から画像名取得・・・元場所：IkiKaiso2.ModRibbon
'FileExists ・・・元場所：IkiKaiso2.ModRibbon
'OutputShapeToPicture ・・・元場所：IkiKaiso2.ModRibbon
'ClipText ・・・元場所：IkiKaiso2.ModOther
'宣言セクション※※※※※※※※※※※※※※※※※※※※※※※※※※※
'-----------------------------------
'元場所:IkiKaiso2.ModRibbon.Enum_PictureExtension
Public Enum Enum_PictureExtension
'画像データの拡張子
'20211224
vb_png = 1
vb_jpg = 2
vb_gif = 3
vb_bmp = 4
vb_tif = 5
End Enum
'宣言セクション終了※※※※※※※※※※※※※※※※※※※※※※※※※※※
Public Sub OutputSelectShapeToPicture()
'選択シェイプを画像ファイルとして出力する
'20220304
'20220329 変更
'20221210 出力する画像のファイル名を重複しないように番号を振る
'20230525 出力画像のフルパスをクリップボードに格納
'20250810 ActiveWorkbookが保存されていない新規ブックだった場合の処理追加
'20251018 ActiveWorkbookが保存されていない新規ブックの場合に、1回目の実行では画像の出力先フォルダを選択して、2回目以降は前回選択したフォルダに出力するように処理を追加
'http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/32360945.html
'選択シェイプを取得する
Dim Dummy As Object: Set Dummy = Selection '選択オブジェクトの参照
On Error Resume Next
Dim TYPE_ As String: TYPE_ = TypeName(Dummy.ShapeRange) '選択しているオブジェクトがシェイプならここでエラーが起きない
On Error GoTo 0
Dim Shape As Shape
If TYPE_ = "ShapeRange" Then '選択オブジェクトがShapeRange型
Set Shape = Dummy.ShapeRange(1) 'シェイプとして参照する。ShapeRange型のItemはShape型
Else
Exit Sub '選択オブジェクトがシェイプでなかったので終了する
End If
'ActiveWorkbookが保存されていない新規ブックか判定
Dim IsNotSaved As Boolean
If ActiveWorkbook.Path = "" Then
IsNotSaved = True
Else
IsNotSaved = False
End If
'出力先フォルダの取得または指定
Static LastSelectFolderPath As String '保存されていないブックの場合にユーザーが指定したフォルダを一時保存しておくための静的変数定義
Dim FolderPath As String
If IsNotSaved = True Then '保存されていないブックの場合は保存先フォルダを選択
If LastSelectFolderPath = "" Then '1つ前の実行にて保存先フォルダを指定した
FolderPath = GetActiveBookPathOrSelectFolder("画像の保存先フォルダ選択") '20250810
LastSelectFolderPath = FolderPath 'ユーザー指定のフォルダパスを次の実行まで保存しておく
Else
FolderPath = LastSelectFolderPath
End If
Else
FolderPath = ActiveWorkbook.Path '保存されているブックの場合は保存先フォルダパス
End If
If FolderPath = "" Then Exit Sub '保存先フォルダが選択されなかった場合は終了
FolderPath = ConvOneDrivePath_LocalPath(FolderPath)
'出力する画像ファイルの名前を設定
Dim DefalutShapeName As String
If LastSelectFolderPath = "" Then
DefalutShapeName = Get__出力済み画像から画像名取得("") '20221210
Else
DefalutShapeName = Get__出力済み画像から画像名取得(LastSelectFolderPath) '20221210
End If
Dim ShapeName As String
ShapeName = InputBox("出力する画像ファイルの名前を入力してください", "画像ファイル名入力", DefalutShapeName)
If ShapeName = "" Then Exit Sub
'画像として出力する
Call OutputShapeToPicture(Shape, FolderPath, ShapeName, vb_jpg)
'フルパスをクリップボードに格納
Dim FilePath As String: FilePath = FolderPath & Application.PathSeparator & ShapeName & ".jpg"
Call ClipText(FilePath)
Application.StatusBar = "フルパスをクリップボードに格納しました「" & FilePath & "」"
End Sub
Private Function GetActiveBookPathOrSelectFolder(Caption As String) As String
'ActiveWorkbook.Pathを返すけど、
'ActiveWorkbookが保存されていない新規ブックの場合はフォルダ選択
'20250810
'引数
'Caption・・・フォルダ選択する場合のキャプション
Dim Output As String: Output = ActiveWorkbook.Path
If Output = "" Then 'ActiveWorkbookが保存されていない新規ブックの場合はフォルダ選択
Output = CurDir
Output = SelectFolder(Output, Caption)
'キャンセルなら Output = "" なので注意
End If
GetActiveBookPathOrSelectFolder = Output
End Function
Private Function SelectFolder(ByRef FolderPath As String, _
ByRef Caption As String) _
As String
'フォルダを選択するダイアログを表示してフォルダを選択させる
'選択したフォルダのフルパスを返す
'FolderPath・・・最初に開くフォルダ
'Caption ・・・ダイアログのキャプションに表示する文字列
'ファイル選択ダイアログからフォルダ選択
Dim Output As String
Dim FileDialog As FileDialog
Set FileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FileDialog
.Filters.Clear '初期化
.Title = Caption 'キャプション設定
'最初に表示するフォルダ設定
.InitialFileName = FolderPath & Application.PathSeparator
'ファイル選択
If .Show = True Then
'選択したファイルを取得
Output = .SelectedItems(1)
Else
'ファイルが選択されなかった場合
Output = "" '空白を返す
End If
End With
'出力
SelectFolder = Output
End Function
Private Function ConvOneDrivePath_LocalPath(ByRef Path As String) _
As String
'OneDriveのhttp形式のパスをローカルパスに変換する
'https://d.docs.live.net/********/作業フォルダ/2023年/12月/Book.xlsm
'↓
'C:/Users/[ユーザー名]/OneDrive/作業フォルダ/2023年/12月/Book.xlsm
'引数
'Path・・・変換対象のフォルダパス
'処理
Dim Output As String
Dim TmpSplit As Variant
If Path Like "http*" Then
'パスがhttpから始まるので変換の必要あり
TmpSplit = Split(Path, "/") '「/」で分割
TmpSplit(0) = ""
TmpSplit(1) = ""
TmpSplit(2) = ""
TmpSplit(3) = Environ("OneDrive")
Output = Join(TmpSplit, "\") '\で結合する
Output = Mid(Output, 4)
Else
'変換の必要なし
Output = Path
End If
'出力
ConvOneDrivePath_LocalPath = Output
End Function
Private Function Get__出力済み画像から画像名取得(OptPath As String) As String
'20221210
'20251018 任意のフォルダパスを与えるようにする
Dim Path As String
If OptPath = "" Then
Path = ActiveWorkbook.Path
Else
Path = OptPath
End If
Path = ConvOneDrivePath_LocalPath(Path)
Dim YYYYMMDD As Long: YYYYMMDD = Format(Date, "YYYYMMDD")
Dim Num As Long: Num = 0
Do '番号1つずつ調べて、その画像ファイル名が見つからない（=存在しない）ファイル名を取得する
Num = Num + 1
Dim PictureName As String: PictureName = YYYYMMDD & "_画像" & Num & ".jpg"
If FileExists(Path & "\" & PictureName, False) = False Then
PictureName = YYYYMMDD & "_画像" & Num '拡張子は必要なし
Exit Do
End If
Loop
'出力
Get__出力済み画像から画像名取得 = PictureName
End Function
Private Function FileExists(ByRef FilePath As String, _
Optional ByRef Message As Boolean = False) _
As Boolean
'ファイルパスを指定して、そのファイルの存在を確認
'存在しない場合はFalse、存在する場合はTrueを返す
'20220303
'https://www.softex-celware.com/post/fileexists
'引数
'FilePath ・・・ファイルのフルパス
'[Message]・・・メッセージを表示するか
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Dim Output As Boolean
Dim FileName As String
Dim FolderPath As String
'ファイルの存在確認
If FSO.FileExists(FilePath) = False Then
Output = False
'ファイルが存在しない場合に警告メッセージの表示
If Message = True Then
FileName = FSO.GetFileName(FilePath)
FolderPath = Replace(FilePath, Application.PathSeparator & FileName, "")
MsgBox "フォルダパス" & "「" & FolderPath & "」" & vbLf & _
"ファイル名" & "「" & FileName & "」" & "の存在が確認できませんでした", vbExclamation
End If
Else
Output = True
End If
'結果の出力
FileExists = Output
End Function
Private Sub OutputShapeToPicture(ByRef TargetShape As Shape, _
ByRef FolderPath As String, _
ByRef PictureName As String, _
ByRef PictureExtension As Enum_PictureExtension, _
Optional ByRef Pixcel As Long, _
Optional ByRef Color As Long = rgbWhite, _
Optional Margin As Long = 0)
'シェイプを画像として出力する
'20211204
'20211208 余白を設定可能に
'20211211 Pixcelが小さい場合に余白がおかしくなる問題を解消
'20220610 A1セルが見えていない状態でも出力可能に
'20221106 ファイルパスをOneDrive起動中において変換
'20250808 新規シートで処理することでエラーを回避できそう?なのでそうした。「Err.Number =70 Err.Description = 書き込みができません｡」
'参考：http://blog.livedoor.jp/aero_iki-jibundakemacro/archives/31430924.html
'引数
'TargetShape ・・・出力する対象のシェイプ
'FolderPath ・・・出力先フォルダパス
'PictureName ・・・出力する画像のファイル名
'PictureExtension・・・出力する画像の拡張子
'[Pixcel] ・・・出力画像の横幅ピクセル値
'[Color] ・・・出力画像の背景画像/省略なら白
'[Margin] ・・・上下左右方向の余白
Dim Zoom As Double '出力する横幅ピクセル値(Pixcel)に合わしてのシェイプの倍率設定
If Pixcel = 0 Then
' Zoom = 1 'Pixcelの設定がない場合は倍率なしの1
Zoom = 2 '画質をちょっと上げるために2に変更
Else
Zoom = Pixcel / TargetShape.Width / 1.463 '謎の係数1.463
End If
'チャートを用意する別シートを作成(後でActiveSheetを表示中にするため：裏で動きが見えないようにして処理を高速化)
Dim NowSheet As Worksheet: Set NowSheet = ActiveSheet
Dim Sheet As Worksheet: Set Sheet = ActiveWorkbook.Worksheets.Add
'出力するシェイプの線幅の設定と、チャート用意、シェイプのコピー
Call TargetShape.CopyPicture 'シェイプをコピーする
'シェイプを貼り付けるチャートを作成する
Dim Chart As ChartObject
Set Chart = Sheet.ChartObjects.Add(0, 0, TargetShape.Width * Zoom + Margin * 2, TargetShape.Height * Zoom + Margin * 2)
Chart.Name = "出力用"
'シェイプをオブジェクトとして参照しておく。
Dim Shape As Shape: Set Shape = Sheet.Shapes("出力用")
'出力する画像ファイルの拡張子設定
Dim Extension As String
Select Case PictureExtension
Case Enum_PictureExtension.vb_jpg
Extension = "jpg"
Case Enum_PictureExtension.vb_png
Extension = "png"
Case Enum_PictureExtension.vb_gif
Extension = "gif"
Case Enum_PictureExtension.vb_bmp
Extension = "bmp"
Case Enum_PictureExtension.vb_tif
Extension = "tif"
End Select
'出力ファイル名設定
Dim FileName As String: FileName = FolderPath & Application.PathSeparator & PictureName & "." & Extension
'チャートオブジェクトの出力
With Chart
' Application.Wait Now() + TimeValue("00:00:01") '1秒待つ。出力失敗を回避できる
DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents: DoEvents 'VBAを落ち着かせる。
.Chart.Paste 'コピーしたシェイプをチャート内に貼り付ける
NowSheet.Select 'ActiveSheetを表示しておく
Shape.Fill.ForeColor.RGB = Color '背景画像設定(シェイプオブジェクトからしかできない)
.Chart.Shapes(1).Width = .Width - Margin * 2 '貼り付けたシェイプの幅を合わせる。余白の分小さくする
.Chart.Shapes(1).Height = .Height - Margin * 2 '貼り付けたシェイプの高さを合わせる。余白の分小さくする
.Chart.Shapes(1).Top = Margin '上下方向の余白確保
.Chart.Shapes(1).Left = Margin '左右方向の余白確保
.Chart.Export FileName '出力名を設定してファイルとして出力
.Delete '出力したシェイプの削除。立つ鳥跡を濁さず。
End With
'チャート貼付用のシートは消去しておく
Application.DisplayAlerts = False
Sheet.Delete
Application.DisplayAlerts = True
End Sub
Private Sub ClipText(ByVal Text As Variant)
'テキストをクリップボードに格納
'テキストが配列ならば列方向をTab区切り、行方向を改行
'https://www.softex-celware.com/post/cliptext
'20251007 テキストのみの処理に変更
'引数
'Text・・・クリップボードに格納するテキスト
'クリップボードに格納
With CreateObject("Forms.TextBox.1")
.MultiLine = True
.Text = Text
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment