Excelでドット絵作成ツールを作る その5
現状報告
こんな感じです。
うまくいっていなかった以下の点を修正してみました。
左側に変な白い部分ができる
グラフを先に作成していて、それがCopyPicture の際に見切れていたため。*1
CopyPictureの後にグラフを作るようにしました。
貼り付けがうまくいかず、真っ白になる
試行錯誤の末、「cht.Parent.Select」を入れることで安定したような気がしなくもない感じです。
コード
現時点でのコードは
'///シートモジュール/// Option Explicit Private Sub Worksheet_Change(ByVal target As Range) Call junbi '共通変数セット If target.Address = TateAddress Or target.Address = YokoAddress Then Call setCamvas 'キャンバスセット Exit Sub End If End Sub Private Sub Worksheet_SelectionChange(ByVal target As Range) ' Debug.Print target.Address '選択範囲多すぎる場合何もしない If target.Count > 1000 Then Exit Sub End If Call junbi '共通変数セット '//描画色選択// Dim lngNewColor As Long '(カラーピッカー) If target.Address = DrawColorAddress Then lngNewColor = GetColorDlg Call changeDrawColor(lngNewColor) Exit Sub End If '(選択履歴) If target.Count = 1 And _ Not Application.Intersect(target, Range(RirekiAddress)) Is Nothing Then lngNewColor = target.Interior.Color Call changeDrawColor(lngNewColor) Exit Sub End If Call drawCells(target) '描画 End Sub '///標準モジュール/// Option Explicit Public Const DrawColorAddress As String = "$B$4:$B$5" Public Const RirekiAddress As String = "$D$1:$D$35" Public Const TateAddress As String = "$B$15" Public Const YokoAddress As String = "$B$18" Public Const CamvasBaseAddress As String = "$F$1" Public BaseRng As Range Public CamvasRng As Range Public Tate As Long, Yoko As Long Sub junbi() '手動モードなら何もしない If Range("A1") = "手動モード" Then End End If '共通変数をセット Set BaseRng = Range(CamvasBaseAddress) Tate = Range("B15") Yoko = Range("B18") Set CamvasRng = Range(BaseRng, Cells(BaseRng.Row + Tate + 1, _ BaseRng.Column + Yoko + 1)) End Sub '描画色変更 Sub changeDrawColor(lngNewColor As Long) Dim i As Long If Range(DrawColorAddress).Interior.Color = lngNewColor Then Exit Sub End If Range(DrawColorAddress).Interior.Color = lngNewColor Range("A1").Select '色選択履歴 Dim fnd As Boolean fnd = False For i = 1 To 35 If Cells(i, 4).Interior.Color = lngNewColor Then fnd = True Exit For End If Next If fnd Then Exit Sub '新しい色が履歴にある場合何もしない For i = 35 To 2 Step -1 Cells(i, 4).Interior.Color = Cells(i - 1, 4).Interior.Color Next Cells(1, 4).Interior.Color = lngNewColor End Sub 'キャンバス Sub setCamvas() Dim r As Range Application.ScreenUpdating = False Cells.Interior.Pattern = xlSolid For Each r In CamvasRng If r.Row = BaseRng.Row Or r.Row = BaseRng.Row + Tate + 1 Or _ r.Column = BaseRng.Column Or r.Column = BaseRng.Column + Yoko + 1 Then r.Interior.Pattern = xlGrid End If Next Application.ScreenUpdating = True End Sub '描画 Sub drawCells(target As Range) Dim r As Range Dim copyRng As Range Dim minCol As Long, maxCol As Long Dim minRow As Long, maxRow As Long Dim clr1 As Long '描画色 clr1 = Range(DrawColorAddress).Interior.Color minCol = BaseRng.Column + 1 maxCol = BaseRng.Column + Yoko minRow = BaseRng.Row + 1 maxRow = BaseRng.Row + Tate Set copyRng = Sheets("ドット絵作成").Range _ (Cells(minRow, minCol), Cells(maxRow, maxCol)) For Each r In target If minCol <= r.Column And r.Column <= maxCol And _ minRow <= r.Row And r.Row <= maxRow Then ' Debug.Print r.Address r.Interior.Color = clr1 End If Next End Sub '///標準モジュール(色選択)/// Option Explicit Private Type ChooseColor lStructSize As Long hWndOwner As Long hInstance As Long rgbResult As Long lpCustColors As String flags As Long lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _ (pChoosecolor As ChooseColor) As Long Private Const CC_RGBINIT = &H1 '色のデフォルト値を設定 Private Const CC_LFULLOPEN = &H2 '色の作成を行う部分を表示 Private Const CC_PREVENTFULLOPEN = &H4 '色の作成ボタンを無効にする Private Const CC_SHOWHELP = &H8 'ヘルプボタンを表示 Public Function GetColorDlg() As Long '機能 : 色の設定ダイアログを表示し、そこで選択された色のRGB値を返す '引数 : lngDefColor デフォルト表示する色 '返値 : 成功時 RGB値 キャンセル時-1 エラー時 -2 (ゼロは黒なので注意) Dim udtChooseColor As ChooseColor Dim lngRet As Long Dim lngDefColor As Long lngDefColor = Range(DrawColorAddress).Interior.Color With udtChooseColor 'ダイアログの設定 .lStructSize = Len(udtChooseColor) .lpCustColors = String$(64, Chr$(0)) .flags = CC_RGBINIT + CC_LFULLOPEN .rgbResult = lngDefColor 'ダイアログを表示 lngRet = ChooseColor(udtChooseColor) 'ダイアログからの返り値をチェック If lngRet <> 0 Then If .rgbResult > RGB(255, 255, 255) Then 'エラー GetColorDlg = -2 Else '正常終了、RGB値を返り値にセット GetColorDlg = .rgbResult End If Else 'キャンセルが押されたとき GetColorDlg = -1 End If End With End Function '///標準モジュール(画像出力)/// Option Explicit Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Ext As String '拡張子 'ファイル保存ダイアログ Function getSaveFileName() As String Dim fPath As String Dim strExt As String strExt = Ext & "ファイル, *." & LCase(Ext) & ", 全てのファイル,*.*" fPath = Application.GetSaveAsFilename(fileFilter:=strExt) If fPath = "False" Then getSaveFileName = "" Else getSaveFileName = fPath End If End Function '画像出力 Sub imgOut() Dim rg As Range Dim cht As Chart Dim fName As String Ext = Range("A23") '保存ファイル名を取得 fName = getSaveFileName If fName <> "" Then '出力範囲をセット Set BaseRng = Range(CamvasBaseAddress) Tate = Range("B15") Yoko = Range("B18") 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:=fName, filtername:=Ext cht.Parent.Delete Application.ScreenUpdating = True End If End Sub
こんな感じです。
修正以外に
- 各種画像拡張子に対応
- 色選択履歴がダブらないように変更
あたりを実装しています。
*1:アホすぎる