Excelでドット絵作成ツールを作る　その10

はじめに
現状報告
コード
新規ブックに出力

はじめに

前回、

vba-belle-equipe.hatenablog.com

ボタンの押せない感を出すことにトライしました。

現状報告

f:id:vba-belle-equipe:20160523202355p:plain

こんな感じです。

「ブック出力」ボタンでファイル選択画面が開き、

f:id:vba-belle-equipe:20160523202451p:plain

選択したブックには、描画部分のみコピーされて保存されます。

f:id:vba-belle-equipe:20160523202522p:plain

コード

現時点でのコードは

'///標準モジュール///    <<画像出力>>

Option Explicit

Private Ext As String   '拡張子
Dim SavePath As String

'ファイル保存ダイアログ
Function getSavePath() As String
  Dim fPath As String
  Dim strExt As String
  strExt = Ext & "ファイル, *." & LCase(Ext) & ", 全てのファイル,*.*"
  fPath = Application.GetSaveAsFilename(fileFilter:=strExt)
  If fPath = "False" Then
    getSavePath = ""
  Else
    getSavePath = fPath
  End If
End Function

'画像出力
Sub imgOut()
  Dim rg As Range
  Dim cht As Chart
  Ext = Range("A23")
  '保存ファイル名を取得
  SavePath = getSavePath
  If SavePath <> "" Then
    Call setSettings    '設定を共通変数にセット
    Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _
                            BaseRng.Column + Yoko))
    Application.ScreenUpdating = False
    rg.CopyPicture appearance:=xlScreen, Format:=xlPicture
    'チャートを追加して画像貼り付け
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart
    cht.Parent.Select
    cht.Paste
    cht.Export FileName:=SavePath, filtername:=Ext
    cht.Parent.Delete
    Application.ScreenUpdating = True
  End If
End Sub

'ブックに出力
Sub outToNewBook()
  Dim ws As Worksheet, cpWs As Worksheet
  Dim wb As Workbook
  Dim rg As Range
  Ext = "xlsx"
    '保存ファイル名を取得
  SavePath = getSavePath
  If SavePath <> "" Then
    Set cpWs = Sheets("ドット絵")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    cpWs.Cells.Clear
    Call setSettings    '設定を共通変数にセット
    Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _
                            BaseRng.Column + Yoko))
    rg.Copy Destination:=cpWs.Range("A1")
    Set wb = Workbooks.Add
    cpWs.Copy before:=wb.Worksheets(1)
    For Each ws In wb.Worksheets
      If ws.Name <> cpWs.Name Then
        ws.Delete
      End If
    Next
    On Error GoTo err
    wb.SaveAs FileName:=SavePath
    On Error GoTo 0
    
    wb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
  End If
  Exit Sub
  
err:
    wb.Close
    MsgBox "出力できません"
    End
End Sub