VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "SheetCanvas" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = True Option Explicit Private Type POINTAPI X As Long Y As Long End Type Private Type TERRITORY T As Long L As Long H As Long W As Long End Type Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long 'タイマ割り込み変更 Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long 'タイマ割り込み元に戻す Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'スリープ Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long 'ディスプレイ座標取得 Private Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long 'キー入力検知 Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long 'DPI取得 Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long 'DPI取得 Private Declare Sub ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As Long) 'DPI取得 Private Const LOGPIXELSX As Long = &H58& Private Const LOGPIXELSY As Long = &H5A& Private PAP_Dpi As POINTAPI 'DPI Private Bol_Init As Boolean '起動の有無 Private PAP_FormTool As POINTAPI 'りっぷ2(りっぷつぅ)の座標位置 Private PAP_FormPalette As POINTAPI 'パレットの座標位置 Private PAP_Ptsp As POINTAPI 'ウインドウ座標の差分 Private Sng_ScaleY As Single '画面の縮尺(縦) Private Sng_ScaleX As Single '画面の縮尺(横) Private TRT_MaskSize As TERRITORY 'マスクサイズ Private Rng_Log As Range '履歴シートのセル Private Rng_Clip As Range 'クリップシートのセル Private Lng_PenType As Long 'ペン先(1=ノーマル、2=スポイト、3=ユビサキ、4=クリップ) Private Bol_PenClip As Boolean 'クリップの中抜き Private Lng_PenColorMain As Long 'ペンの色、主 Private Lng_PenColorSub As Long 'ペンの色、副 Private PAP_PenSize As POINTAPI 'ペンの大きさ Private Lng_PenInterval As Long 'ペンの間隔 Private Lng_PenSpray As Long 'スプレー Private Bol_Mask As Boolean 'マスク(False=オフ、True=オン) Private Lng_LogMax As Long '履歴の最大数 Private Lng_LogPos As Long '履歴番号 Private Lng_LogRedo As Long 'リドゥ可能回数 Private Lng_LogUndo As Long 'アンドゥ可能回数 Private Bol_Log As Boolean '履歴取得の有無 Private PAP_CellSize As POINTAPI 'セルの幅 Private PAP_CanvasMax As POINTAPI 'カンバスの最大サイズ Private PAP_CanvasSize As POINTAPI 'カンバスサイズ Private PAP_ClipSize As POINTAPI 'クリップの大きさ Private Sub setInitialize() '初期化 Dim Msg_ans As Long, For_cnt As Long Msg_ans = MsgBox("りっぷ2(りっぷつぅ)を起動します", vbYesNo) If Msg_ans = 7 Then 'いいえ Exit Sub '帰る End If Randomize '乱数初期化 setDpi 'DPIをセット PAP_CanvasMax.Y = 2000 PAP_CanvasSize.Y = PAP_CanvasMax.Y 'カンバスサイズ(縦) If 2000 < Cells.Columns.Count Then '最大列数が2000より大きければ(Excel2007以降) PAP_CanvasMax.X = 2000 Else PAP_CanvasMax.X = 256 End If PAP_CanvasSize.X = PAP_CanvasMax.X 'カンバスサイズ(横) If PAP_CanvasMax.Y * 64 < Cells.Rows.Count Then '履歴を64個確保できれば Lng_LogMax = 64 'Excel2007以降 Else Lng_LogMax = 32 'Excel2003以前 End If Set Rng_Log = SheetLog.Cells(1) '履歴シートのセル With Application .ScreenUpdating = False '画面更新オフ .StandardFont = "ＭＳ ゴシック" '標準フォントの種類 .StandardFontSize = 11 '標準フォントのサイズ .Cursor = xlNorthwestArrow 'マウスポインタを矢印に変更 Load FormTool 'りっぷ2(りっぷつぅ)をロード FormTool.Show FormPalette.Top = FormTool.Top '縦位置を合わせる FormPalette.Left = FormTool.Left + FormTool.Width '横に並べる SheetClip.Visible = False 'クリップシート、非表示 SheetLog.Visible = False '履歴シート、非表示 .ScreenUpdating = True '画面更新オン End With timeBeginPeriod 1 'タイマ割り込み変更 Bol_Init = True '初期化フラグをオン End Sub Public Function setTerminate() '終了化 Set Rng_Log = Nothing 'オブジェクト解放 Set Rng_Clip = Nothing 'オブジェクト解放 SheetLog.Cells.Clear '履歴シートをクリア timeEndPeriod 1 'タイマ割り込み元に戻す Application.Cursor = xlDefault 'マウスポインタをデフォルトに変更 Bol_Init = False '初期化フラグをオフ End Function Private Sub setDpi() 'DPI取得 Dim hWnd As Long Dim hDc As Long hWnd = Excel.Application.hWnd hDc = GetDC(hWnd) PAP_Dpi.Y = GetDeviceCaps(hDc, LOGPIXELSY) '垂直方向DPI PAP_Dpi.X = GetDeviceCaps(hDc, LOGPIXELSX) '水平方向DPI ReleaseDC hWnd, hDc End Sub Public Sub setInit(Init_flg As Boolean) '起動の有無を設定 Bol_Init = Init_flg End Sub Public Function getBol_Init() As Boolean '起動の有無を取得 getBol_Init = Bol_Init End Function Private Function judgeCanvasIn(Cell_R As Long, Cell_C As Long) As Boolean '座標がカンバス内かどうか If TRT_MaskSize.T <= Cell_R And TRT_MaskSize.L <= Cell_C _ And Cell_R <= TRT_MaskSize.H And Cell_C <= TRT_MaskSize.W Then judgeCanvasIn = True End If End Function Private Sub Worksheet_Activate() 'アクティブになった時 changeShowHide True 'りっぷ2(りっぷつぅ)の表示 End Sub Private Sub Worksheet_Deactivate() 'アクティブが他に移った時 changeShowHide False 'りっぷ2(りっぷつぅ)の非表示 End Sub Public Sub changeShowHide(ShowIs_true As Boolean) 'りっぷ2(りっぷつぅ)の表示、非表示 If ShowIs_true Then '表示させるなら If Bol_Init Then 'りっぷ2(りっぷつぅ)が起動していれば FormTool.Show FormTool.Top = PAP_FormTool.Y '上位置 FormTool.Left = PAP_FormTool.X '左位置 FormPalette.Show FormPalette.Top = PAP_FormPalette.Y '上位置 FormPalette.Left = PAP_FormPalette.X '左位置 End If Else If Bol_Init Then 'りっぷ2(りっぷつぅ)が起動していれば PAP_FormTool.Y = FormTool.Top '上位置 PAP_FormTool.X = FormTool.Left '左位置 FormTool.Hide PAP_FormPalette.Y = FormPalette.Top '上位置 PAP_FormPalette.X = FormPalette.Left '左位置 FormPalette.Hide End If End If End Sub '■描画 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) '右クリック If Bol_Init = 0 Then Cancel = True '右クリックのコンテキストメニュー非表示 setInitialize '起動(初期化) Exit Sub '帰る End If With ActiveWindow If .Split Or .FreezePanes Or .Zoom <> 100 Then 'ウインドウ分割、ウインドウ枠固定、拡大率100%なら Exit Sub End If Cancel = True '右クリックのコンテキストメニュー非表示 PAP_Ptsp.Y = .PointsToScreenPixelsY(0) 'ウインドウ座標の差分(縦) PAP_Ptsp.X = .PointsToScreenPixelsX(0) 'ウインドウ座標の差分(横) End With Sng_ScaleY = PAP_Dpi.Y * PAP_CellSize.Y / 96 Sng_ScaleX = PAP_Dpi.X * PAP_CellSize.X / 96 If Bol_Mask Then 'マスクがオンなら With Target 'マスクサイズ TRT_MaskSize.T = .Row TRT_MaskSize.L = .Column TRT_MaskSize.H = .Row + .Rows.Count - 1 TRT_MaskSize.W = .Column + .Columns.Count - 1 End With End If Select Case Lng_PenType Case 0 'ノーマル Select Case Lng_PenSpray Case 0 'スプレーなし drawNormal Case 1 '普通 drawNormalSpray Case 2 '混合 drawNormalMix Case 3 '副のみ drawNormalSubOnly Case 4 '副以外 drawNormalNotSub End Select Case 1 'スポイト Select Case Lng_PenSpray Case 0 'スプレーなし drawSpuit Case 1 '普通 drawSpuitSpray Case 2 '混合 drawSpuitMix Case 3 '副のみ drawSpuitSubOnly Case 4 '副以外 drawSpuitNotSub End Select Case 2 'ユビサキ Select Case Lng_PenSpray Case 0 'スプレーなし drawFinger Case 1 '普通 drawFingerSpray Case 2 '混合 drawFingerMix Case 3 '副のみ drawFingerSubOnly Case 4 '副以外 drawFingerNotSub End Select Case 3 'クリップ If Bol_PenClip Then 'クリップ中抜きがオンなら Select Case Lng_PenSpray Case 0 'スプレーなし(クリップ中抜き) drawClipIn Case 1 '普通(クリップ中抜き) drawClipSprayIn Case 2 '混合(クリップ中抜き) drawClipMixIn Case 3 '副のみ(クリップ中抜き) drawClipSubOnlyIn Case 4 '副以外(クリップ中抜き) drawClipNotSubIn End Select Else Select Case Lng_PenSpray Case 0 'スプレーなし drawClip Case 1 '普通 drawClipSpray Case 2 '混合 drawClipMix Case 3 '副のみ drawClipSubOnly Case 4 '副以外 drawClipNotSub End Select End If End Select If Bol_Mask Then 'マスクがオンなら With TRT_MaskSize 'カンバスサイズ .T = 1 .L = 1 .H = PAP_CanvasSize.Y .W = PAP_CanvasSize.X End With End If setLog '履歴取得 End Sub '■ノーマル Private Sub drawNormal() 'なし Dim Yx As POINTAPI, Rc As POINTAPI Dim Pen As TERRITORY Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.T = Rc.Y - (PAP_PenSize.Y - 1) \ 2 Pen.L = Rc.X - (PAP_PenSize.X - 1) \ 2 Pen.H = Rc.Y + PAP_PenSize.Y \ 2 Pen.W = Rc.X + PAP_PenSize.X \ 2 If judgeCanvasIn(Pen.T, Pen.L) And judgeCanvasIn(Pen.H, Pen.W) Then Range(Cells(Pen.T, Pen.L), Cells(Pen.H, Pen.W)).Interior.ColorIndex = Lng_PenColorMain End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawNormalSpray() '普通 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawNormalMix() '混合 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Dim Mix_flg As Boolean Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Mix_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain Else Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub End If Mix_flg = Not Mix_flg End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawNormalSubOnly() '副のみ Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawNormalNotSub() '副以外 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex <> Lng_PenColorSub Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub '■スポイト Private Sub drawSpuit() 'なし Dim Yx As POINTAPI, Rc As POINTAPI Dim Pen As TERRITORY Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.T = Rc.Y - (PAP_PenSize.Y - 1) \ 2 Pen.L = Rc.X - (PAP_PenSize.X - 1) \ 2 Pen.H = Rc.Y + PAP_PenSize.Y \ 2 Pen.W = Rc.X + PAP_PenSize.X \ 2 If judgeCanvasIn(Pen.T, Pen.L) And judgeCanvasIn(Pen.H, Pen.W) Then Range(Cells(Pen.T, Pen.L), Cells(Pen.H, Pen.W)).Interior.ColorIndex _ = Cells(Rc.Y, Rc.X).Interior.ColorIndex End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawSpuitSpray() '普通 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + (PAP_PenSize.Y) \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + (PAP_PenSize.X) \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) And judgeCanvasIn(Rc.Y, Rc.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Cells(Rc.Y, Rc.X).Interior.ColorIndex End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawSpuitMix() '混合 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Dim Mix_flg As Boolean, Clr_flg As Boolean Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Mix_flg Then If judgeCanvasIn(Rc.Y, Rc.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Cells(Rc.Y, Rc.X).Interior.ColorIndex End If Else If Clr_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain Else Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub End If Clr_flg = Not Clr_flg End If Mix_flg = Not Mix_flg End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawSpuitSubOnly() '副のみ Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub And judgeCanvasIn(Rc.Y, Rc.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Cells(Rc.Y, Rc.X).Interior.ColorIndex End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawSpuitNotSub() '副以外 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex <> Lng_PenColorSub And judgeCanvasIn(Rc.Y, Rc.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Cells(Rc.Y, Rc.X).Interior.ColorIndex End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub '■ユビサキ Private Sub drawFinger() 'なし Dim Yx As POINTAPI, Rc As POINTAPI Dim Pen As TERRITORY Dim Clr_no As Long GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 If judgeCanvasIn(Rc.Y, Rc.X) Then Clr_no = Cells(Rc.Y, Rc.X).Interior.ColorIndex Else Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.T = Rc.Y - (PAP_PenSize.Y - 1) \ 2 Pen.L = Rc.X - (PAP_PenSize.X - 1) \ 2 Pen.H = Rc.Y + PAP_PenSize.Y \ 2 Pen.W = Rc.X + PAP_PenSize.X \ 2 If judgeCanvasIn(Pen.T, Pen.L) And judgeCanvasIn(Pen.H, Pen.W) Then Range(Cells(Pen.T, Pen.L), Cells(Pen.H, Pen.W)).Interior.ColorIndex = Clr_no End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawFingerSpray() '普通 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Dim Clr_no As Long GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 If judgeCanvasIn(Rc.Y, Rc.X) Then Clr_no = Cells(Rc.Y, Rc.X).Interior.ColorIndex Else Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Clr_no End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawFingerMix() '混合 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Dim Mix_flg As Boolean, Clr_flg As Boolean Dim Clr_no As Long GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 If judgeCanvasIn(Rc.Y, Rc.X) Then Clr_no = Cells(Rc.Y, Rc.X).Interior.ColorIndex Else Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Mix_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Clr_no Else If Clr_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain Else Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub End If Clr_flg = Not Clr_flg End If Mix_flg = Not Mix_flg End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawFingerSubOnly() '副のみ Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Dim Clr_no As Long GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 If judgeCanvasIn(Rc.Y, Rc.X) Then Clr_no = Cells(Rc.Y, Rc.X).Interior.ColorIndex Else Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Clr_no End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawFingerNotSub() '副以外 Dim Yx As POINTAPI, Rc As POINTAPI, Pen As POINTAPI Dim Clr_no As Long GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 If judgeCanvasIn(Rc.Y, Rc.X) Then Clr_no = Cells(Rc.Y, Rc.X).Interior.ColorIndex Else Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.Y = Rc.Y + PAP_PenSize.Y \ 2 - Int(Rnd * PAP_PenSize.Y) Pen.X = Rc.X + PAP_PenSize.X \ 2 - Int(Rnd * PAP_PenSize.X) If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex <> Lng_PenColorSub Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Clr_no End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub '■クリップ Private Sub drawClip() 'なし Dim Yx As POINTAPI, Rc As POINTAPI Dim Pen As TERRITORY If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Pen.T = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 Pen.L = Rc.X - (PAP_ClipSize.X - 1) \ 2 Pen.H = Rc.Y + PAP_ClipSize.Y \ 2 Pen.W = Rc.X + PAP_ClipSize.X \ 2 If judgeCanvasIn(Pen.T, Pen.L) And judgeCanvasIn(Pen.H, Pen.W) Then Rng_Clip.Copy Cells(Pen.T, Pen.L) End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipSpray() '普通 Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipMix() '混合 Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI Dim Mix_flg As Boolean, Clr_flg As Boolean If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If Mix_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Else If Clr_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain Else Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub End If Clr_flg = Not Clr_flg End If Mix_flg = Not Mix_flg End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipSubOnly() '副のみ Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipNotSub() '副以外 Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex <> Lng_PenColorSub Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipIn() 'なし(クリップ中抜き) Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y + PAP_ClipSize.Y \ 2 - Rd.Y Pen.X = Rc.X + PAP_ClipSize.X \ 2 - Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If 0 < Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipSprayIn() '普通(クリップ中抜き) Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If 0 < Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipMixIn() '混合(クリップ中抜き) Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI Dim Mix_flg As Boolean, Clr_flg As Boolean If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If 0 < Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Then If Mix_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Else If Clr_flg Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorMain Else Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub End If Clr_flg = Not Clr_flg End If Mix_flg = Not Mix_flg End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipSubOnlyIn() '副のみ(クリップ中抜き) Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex = Lng_PenColorSub Then If 0 < Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex End If End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Private Sub drawClipNotSubIn() '副以外(クリップ中抜き) Dim Yx As POINTAPI, Rc As POINTAPI, Rd As POINTAPI, Pen As POINTAPI If PAP_ClipSize.Y = 0 Or PAP_ClipSize.X = 0 Then MsgBox "クリップが登録されてません" Exit Sub End If Do GetCursorPos Yx Rc.Y = (Yx.Y - PAP_Ptsp.Y) \ Sng_ScaleY + 1 Rc.X = (Yx.X - PAP_Ptsp.X) \ Sng_ScaleX + 1 Rd.Y = Int(Rnd * PAP_ClipSize.Y) Rd.X = Int(Rnd * PAP_ClipSize.X) Pen.Y = Rc.Y - (PAP_ClipSize.Y - 1) \ 2 + Rd.Y Pen.X = Rc.X - (PAP_ClipSize.X - 1) \ 2 + Rd.X If judgeCanvasIn(Pen.Y, Pen.X) Then If Cells(Pen.Y, Pen.X).Interior.ColorIndex <> Lng_PenColorSub Then If 0 < Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex Then Cells(Pen.Y, Pen.X).Interior.ColorIndex = Rng_Clip(Rd.Y + 1, Rd.X + 1).Interior.ColorIndex End If End If End If Sleep Lng_PenInterval Loop While GetAsyncKeyState(vbKeyRButton) End Sub Public Sub setPenClip(OnIs_True As Boolean) 'パレットの中抜き Bol_PenClip = OnIs_True End Sub '■パレット Public Function getPenColor(MainIs_true As Boolean) 'ペンの色を取得 If MainIs_true Then getPenColor = Lng_PenColorMain '主 Else getPenColor = Lng_PenColorSub '副 End If End Function Public Sub setPenColor(Clr_no As Long, MainIs_true As Boolean) 'ペンの色 If (0 < Clr_no And Clr_no < 57) Or Clr_no = -4142 Then 'インデックス内または塗りつぶしなしなら If MainIs_true Then Lng_PenColorMain = Clr_no '主 Else Lng_PenColorSub = Clr_no '副 End If End If End Sub Public Function changePenColor() '主⇔副 Dim Clr_no As Long Clr_no = Lng_PenColorMain '一時保存 Lng_PenColorMain = Lng_PenColorSub '主←副 Lng_PenColorSub = Clr_no '副←一時保存 End Function '■基本 Public Sub setPenType(Pen_type) 'ペンの種類を設定 Lng_PenType = Pen_type End Sub Public Function getPenType() As Long 'ペンの種類を取得 getPenType = Lng_PenType End Function Public Function getPenSpray() As Long 'スプレーの種類を取得 getPenSpray = Lng_PenSpray End Function Public Sub setPenSpray(Spray_no As Long) 'スプレーの種類を設定 Lng_PenSpray = Spray_no End Sub Public Function getPenSize(YisF_XisT As Boolean) As Long 'ペンの大きさを取得 If YisF_XisT Then getPenSize = PAP_PenSize.X '横 Else getPenSize = PAP_PenSize.Y '縦 End If End Function Public Sub setPenSize(Pen_size As Long, YisF_XisT As Boolean) 'ペンの大きさを設定 If YisF_XisT Then PAP_PenSize.X = Pen_size '横 Else PAP_PenSize.Y = Pen_size '縦 End If End Sub Public Function getPenInterval() As Long 'ペンの間隔を取得 getPenInterval = Lng_PenInterval End Function Public Sub setPenInterval(Interval_size As Long) 'ペンの間隔を設定 Lng_PenInterval = Interval_size End Sub Private Sub setLog() '履歴取得 If Bol_Log Then '履歴が有効なら If Lng_LogPos = Lng_LogMax - 1 Then '履歴シートの最下部なら Lng_LogPos = 0 Else Lng_LogPos = Lng_LogPos + 1 End If Cells(1).Resize(PAP_CanvasSize.Y, PAP_CanvasSize.X).Copy Rng_Log.Offset(Lng_LogPos * PAP_CanvasMax.Y, 0) If Lng_LogRedo < Lng_LogMax - 1 Then 'リドゥ回数が上限でなければ Lng_LogRedo = Lng_LogRedo + 1 End If Lng_LogUndo = 0 'アンドゥ不可 End If End Sub Public Function deleteLog() '履歴削除 SheetLog.Cells.Clear Lng_LogPos = 0 '履歴番号 Lng_LogRedo = -1 'リドゥ可能回数 Lng_LogUndo = 0 'アンドゥ可能回数 setLog '履歴取得 End Function Public Function reduLog() 'リドゥ If 0 < Lng_LogRedo Then '前の履歴があるなら If Lng_LogPos Then '履歴シートの最上部でないなら Lng_LogPos = Lng_LogPos - 1 Else Lng_LogPos = Lng_LogMax - 1 '最下部 End If Lng_LogRedo = Lng_LogRedo - 1 'リドゥ可能回数-1 Lng_LogUndo = Lng_LogUndo + 1 'アンドゥ可能回数+1 Rng_Log.Offset(PAP_CanvasMax.Y * Lng_LogPos, 0).Resize(PAP_CanvasSize.Y, PAP_CanvasSize.X).Copy Cells(1) Else MsgBox "リドゥできる履歴がありません" End If End Function Public Function undoLog() 'アンドゥ If Lng_LogUndo Then '後の履歴があるなら If Lng_LogPos < Lng_LogMax - 1 Then '履歴シートの最下部でないなら Lng_LogPos = Lng_LogPos + 1 Else Lng_LogPos = 0 '最上部 End If Lng_LogRedo = Lng_LogRedo + 1 'リドゥ可能回数+1 Lng_LogUndo = Lng_LogUndo - 1 'アンドゥ可能回数-1 Rng_Log.Offset(PAP_CanvasMax.Y * Lng_LogPos, 0).Resize(PAP_CanvasSize.Y, PAP_CanvasSize.X).Copy Cells(1) Else MsgBox "アンドゥできる履歴がありません" End If End Function Public Sub changeLog(On_IsTrue As Boolean) '履歴の有無 Bol_Log = On_IsTrue If On_IsTrue Then setLog '履歴取得 End If End Sub Public Function getLogMax() '履歴の最大数を取得 getLogMax = Lng_LogMax End Function Public Sub setMask(OnIs_True As Boolean) 'マスク Bol_Mask = OnIs_True End Sub Public Sub clearRange(Canvas_Selection As Boolean) '指定範囲を消去 If Canvas_Selection Then 'True(カンバス)なら Cells.Clear '全て SheetCanvas.DrawingObjects.Delete 'オブジェクト全削除 Else If TypeName(Selection) = "Range" Then 'セルが選択されていれば Selection.Clear '指定範囲 End If End If setLog '履歴取得 End Sub Public Function getCellSize(YisF_XisT As Boolean) 'セルの幅を取得 If YisF_XisT Then getCellSize = PAP_CellSize.X '横 Else getCellSize = PAP_CellSize.Y '縦 End If End Function '■応用 Public Function getCanvasMax(YisF_XisT As Boolean) 'カンバスサイズを取得 If YisF_XisT Then getCanvasMax = PAP_CanvasMax.X '横 Else getCanvasMax = PAP_CanvasMax.Y '縦 End If End Function Public Function getCanvasSize(YisF_XisT As Boolean) 'カンバスサイズを取得 If YisF_XisT Then getCanvasSize = PAP_CanvasSize.X '横 Else getCanvasSize = PAP_CanvasSize.Y '縦 End If End Function Public Sub setCellCanvasSize(Cell_y As Long, Cell_x As Long _ , Cnv_y As Long, Cnv_x As Long) 'セル幅、カンバスサイズを設定 If Cnv_y < 1 Or Cnv_x < 1 Or PAP_CanvasMax.Y < Cnv_y Or PAP_CanvasMax.X < Cnv_x Then MsgBox "カンバスサイズが不正です" & Chr(10) _ & "縦の範囲：1〜" & PAP_CanvasMax.Y & "、横の範囲：1〜" & PAP_CanvasMax.X Else PAP_CanvasSize.Y = Cnv_y 'カンバスサイズ(縦) Rows.Hidden = False '行、再表示 PAP_CellSize.Y = Cell_y 'セル幅(縦) Cells.RowHeight = Cell_y * 0.75 '縦(ポイント) Rows(CStr(Cnv_y + 1) & ":" & CStr(Rows.Count)).Hidden = True '行、非表示 PAP_CanvasSize.X = Cnv_x 'カンバスサイズ(横) Columns.Hidden = False '列、再表示 PAP_CellSize.X = Cell_x 'セル幅(横) Cells.ColumnWidth = Cell_x / 13 '横(文字幅) If Cnv_x < Columns.Count Then Range(Columns(Cnv_x + 1), Columns(Columns.Count)).Hidden = True '列、非表示 End If With TRT_MaskSize 'カンバスサイズ .T = 1 .L = 1 .H = Cnv_y .W = Cnv_x End With End If End Sub Public Sub turnUDorLR(UD_LR As Boolean) '縦or横に反転 Dim For_cnt As Long Dim Rng As TERRITORY With Rng If TypeName(Selection) = "Range" Then 'セルが選択されていれば With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = .Rows.Count '行数 Rng.W = .Columns.Count '列数 End With If PAP_CanvasSize.Y < .H Then .H = PAP_CanvasSize.Y - .T + 1 End If If PAP_CanvasSize.X < .W Then 'カンバスを超えていれば .W = PAP_CanvasSize.X - .L + 1 End If Else Exit Sub '帰る End If Cells(.T, .L).Resize(.H, .W).Copy SheetClip.Cells(PAP_CanvasMax.Y + 1, 1) '一時保存 If UD_LR Then '上下反転なら For For_cnt = 1 To .H SheetClip.Cells(PAP_CanvasMax.Y + For_cnt, 1).Resize(1, .W).Copy _ Cells(.T + .H - For_cnt, .L) Next For_cnt Else '左右反転 For For_cnt = 1 To .W SheetClip.Cells(PAP_CanvasMax.Y + 1, For_cnt).Resize(.H, 1).Copy _ Cells(.T, .L + .W - For_cnt) Next For_cnt End If SheetClip.Cells(PAP_CanvasMax.Y + 1, 1).Resize(.H, .W).Clear '一時保存をクリア End With setLog '履歴取得 End Sub Public Function turnRC() '行and列を反転 Dim For_cnt As Long Dim Rng As TERRITORY With Rng If TypeName(Selection) = "Range" Then 'セルが選択されていれば With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = .Rows.Count '行数 Rng.W = .Columns.Count '列数 End With If PAP_CanvasSize.Y < .T + .W - 1 Or PAP_CanvasSize.X < .L + .H - 1 Then 'カンバスを超えていれば MsgBox "対象範囲が不正です" Exit Function '帰る End If Else Exit Function '帰る End If Cells(.T, .L).Resize(.H, .W).Copy SheetClip.Cells(PAP_CanvasMax.Y + 1, 1) '一時保存 SheetClip.Cells(PAP_CanvasMax.Y + 1, 1).Resize(.H, .W).Copy Cells(.T, .L).PasteSpecial Transpose:=True '行列入替 Application.CutCopyMode = False SheetClip.Cells(PAP_CanvasMax.Y + 1, 1).Resize(.H, .W).Clear '一時保存をクリア End With setLog '履歴取得 End Function Public Function changeBack(Change_flg As Boolean) As String '背景画像の設定、削除 Dim File_pass As String, File_name As String If Change_flg Then '背景を変更するなら File_pass = Application.GetOpenFilename _ ("画像ファイル(*.jpeg;*.jpg;*.png;*.gif),*jpeg;*jpg;*.png;*.gif") '画像ファイルのパスを取得 File_name = Dir(File_pass) If Dir(File_pass) = "" Then 'ファイルが存在しなければ changeBack = "" '空白 Else ActiveSheet.SetBackgroundPicture File_pass '背景を設定 changeBack = File_pass 'フルパス End If Else '背景を削除 ActiveSheet.SetBackgroundPicture Filename:=vbNullString '背景を削除 changeBack = "<背景なし>" End If End Function Public Sub paintSquareAll(Paint_ratio As Single) '■、全部 Dim For_rng As Range If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If If PAP_CanvasSize.Y < Selection.Rows.Count _ Or PAP_CanvasSize.X < Selection.Columns.Count Then '第一選択範囲の大きさがカンバス以上なら MsgBox "対象範囲が不正です" & Chr(10) _ & "縦の範囲：1〜" & PAP_CanvasSize.X & "、横の範囲：1〜" & PAP_CanvasSize.X Exit Sub Else If Paint_ratio = 1 Then '濃度：100%なら Selection.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし Else For Each For_rng In Selection '選択範囲を繰り返し If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng End If End If setLog '履歴取得 End Sub Public Sub paintSquareSubOnly(Paint_ratio As Single) '■、副のみ Dim For_rng As Range If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If If PAP_CanvasSize.Y < Selection.Rows.Count _ Or PAP_CanvasSize.X < Selection.Columns.Count Then '第一選択範囲の大きさがカンバス以上なら MsgBox "対象範囲が不正です" & Chr(10) _ & "縦の範囲：1〜" & PAP_CanvasSize.X & "、横の範囲：1〜" & PAP_CanvasSize.X Exit Sub Else If Paint_ratio = 1 Then '濃度：100%なら For Each For_rng In Selection '選択範囲を繰り返し If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If Next For_rng Else For Each For_rng In Selection '選択範囲を繰り返し If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng End If End If setLog '履歴取得 End Sub Public Sub paintSquareNotSub(Paint_ratio As Single) '■、副以外 Dim For_rng As Range If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If If PAP_CanvasSize.Y < Selection.Rows.Count _ Or PAP_CanvasSize.X < Selection.Columns.Count Then '第一選択範囲の大きさがカンバス以上なら MsgBox "対象範囲が不正です" & Chr(10) _ & "縦の範囲：1〜" & PAP_CanvasSize.X & "、横の範囲：1〜" & PAP_CanvasSize.X Exit Sub Else If Paint_ratio = 1 Then '濃度：100%なら For Each For_rng In Selection '選択範囲を繰り返し If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色以外なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If Next For_rng Else For Each For_rng In Selection '選択範囲を繰り返し If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色以外なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng End If End If setLog '履歴取得 End Sub Public Sub paintSquareFrameAll(Width_size As Long) '□、全部 Dim Rng As TERRITORY If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T < Width_size * 2 Or .W - .L < Width_size * 2 Then '線の幅が範囲の1/2以上なら MsgBox "線の太さが大きすぎます" Exit Sub '帰る End If Cells(.T, .L).Resize(Width_size, .W - .L + 1 - Width_size).Interior.ColorIndex _ = Lng_PenColorMain '上端 Cells(.T + Width_size, .L).Resize(.H - .T + 1 - Width_size, Width_size).Interior.ColorIndex _ = Lng_PenColorMain '左端 Cells(.H - Width_size + 1, .L + Width_size).Resize(Width_size, .W - .L + 1 - Width_size).Interior.ColorIndex _ = Lng_PenColorMain '下端 Cells(.T, .W - Width_size + 1).Resize(.H - .T + 1 - Width_size, Width_size).Interior.ColorIndex _ = Lng_PenColorMain '右端 End With setLog '履歴取得 End Sub Public Sub paintSquareFrameSubOnly(Width_size As Long) '□、副のみ Dim For_rng As Range Dim Rng As TERRITORY If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T < Width_size * 2 Or .W - .L < Width_size * 2 Then '線の幅が範囲の1/2以上なら MsgBox "線の太さが大きすぎます" Exit Sub '帰る End If For Each For_rng In Cells(.T, .L).Resize(Width_size, .W - .L + 1 - Width_size) If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '上端 End If Next For_rng For Each For_rng In Cells(.T + Width_size, .L).Resize(.H - .T + 1 - Width_size, Width_size) If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '左端 End If Next For_rng For Each For_rng In Cells(.H - Width_size + 1, .L + Width_size).Resize(Width_size, .W - .L + 1 - Width_size) If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '下端 End If Next For_rng For Each For_rng In Cells(.T, .W - Width_size + 1).Resize(.H - .T + 1 - Width_size, Width_size) If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '右端 End If Next For_rng End With setLog '履歴取得 End Sub Public Sub paintSquareFrameNotSub(Width_size As Long) '□、副以外 Dim For_rng As Range Dim Rng As TERRITORY If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T < Width_size * 2 Or .W - .L < Width_size * 2 Then '線の幅が範囲の1/2以上なら MsgBox "線の太さが大きすぎます" Exit Sub '帰る End If For Each For_rng In Cells(.T, .L).Resize(Width_size, .W - .L + 1 - Width_size) If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '上端 End If Next For_rng For Each For_rng In Cells(.T + Width_size, .L).Resize(.H - .T + 1 - Width_size, Width_size) If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '左端 End If Next For_rng For Each For_rng In Cells(.H - Width_size + 1, .L + Width_size).Resize(Width_size, .W - .L + 1 - Width_size) If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '下端 End If Next For_rng For Each For_rng In Cells(.T, .W - Width_size + 1).Resize(.H - .T + 1 - Width_size, Width_size) If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '右端 End If Next For_rng End With setLog '履歴取得 End Sub Public Sub paintCircleAll(Paint_ratio As Single) '●、全部 Dim Rng As TERRITORY Dim For_rng As Range Dim R_long As Long, R_short As Long, R_long2 As Long, R_short2 As Long, Sqr_size As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = (.W - .L + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.H - .T + 1) \ 2 '短径 R_short2 = R_short * R_short If Paint_ratio = 1 Then '濃度が100%なら If (.W - .L + 1) Mod 2 Then '長径が奇数なら Range(Cells(.T, .L + R_long), Cells(.H, .L + R_long)).Interior.ColorIndex = Lng_PenColorMain '中心 End If For For_cnt = 0 To R_long - 1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ Range(Cells(.T + R_short - Sqr_size, .L + R_long - For_cnt - 1) _ , Cells(.H - R_short + Sqr_size, .L + R_long - For_cnt - 1)).Interior.ColorIndex = Lng_PenColorMain '左 Range(Cells(.T + R_short - Sqr_size, .W - R_long + For_cnt + 1) _ , Cells(.H - R_short + Sqr_size, .W - R_long + For_cnt + 1)).Interior.ColorIndex = Lng_PenColorMain '右 Next For_cnt Else If (.W - .L + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T, .L + R_long), Cells(.H, .L + R_long)) '中心 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng End If For For_cnt = 0 To R_long - 1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ For Each For_rng In Range(Cells(.T + R_short - Sqr_size, .L + R_long - For_cnt - 1) _ , Cells(.H - R_short + Sqr_size, .L + R_long - For_cnt - 1)) '左 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng For Each For_rng In Range(Cells(.T + R_short - Sqr_size, .W - R_long + For_cnt + 1) _ , Cells(.H - R_short + Sqr_size, .W - R_long + For_cnt + 1)) '右 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt End If Else '縦長なら R_long = (.H - .T + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.W - .L + 1) \ 2 '短径 R_short2 = R_short * R_short If Paint_ratio = 1 Then '濃度が100%なら If (.H - .T + 1) Mod 2 Then '長径が奇数なら Range(Cells(.T + R_long, .L), Cells(.T + R_long, .W)).Interior.ColorIndex = Lng_PenColorMain '中心 End If For For_cnt = 0 To R_long - 1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ Range(Cells(.T + R_long - For_cnt - 1, .L + R_short - Sqr_size) _ , Cells(.T + R_long - For_cnt - 1, .W - R_short + Sqr_size)).Interior.ColorIndex = Lng_PenColorMain '上 Range(Cells(.H - R_long + For_cnt + 1, .L + R_short - Sqr_size) _ , Cells(.H - R_long + For_cnt + 1, .W - R_short + Sqr_size)).Interior.ColorIndex = Lng_PenColorMain '下 Next For_cnt Else If (.H - .T + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T + R_long, .L), Cells(.T + R_long, .W)) '中心 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng End If For For_cnt = 0 To R_long - 1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ For Each For_rng In Range(Cells(.T + R_long - For_cnt - 1, .L + R_short - Sqr_size) _ , Cells(.T + R_long - For_cnt - 1, .W - R_short + Sqr_size)) '上 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng For Each For_rng In Range(Cells(.H - R_long + For_cnt + 1, .L + R_short - Sqr_size) _ , Cells(.H - R_long + For_cnt + 1, .W - R_short + Sqr_size)) '下 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt End If End If End With setLog '履歴取得 End Sub Public Sub paintCircleSubOnly(Paint_ratio As Single) '●、副のみ Dim Rng As TERRITORY Dim For_rng As Range Dim R_long As Long, R_short As Long, R_long2 As Long, R_short2 As Long, Sqr_size As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = (.W - .L + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.H - .T + 1) \ 2 '短径 R_short2 = R_short * R_short If (.W - .L + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T, .L + R_long), Cells(.H, .L + R_long)) '中心 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng End If For For_cnt = 0 To R_long - 1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ For Each For_rng In Range(Cells(.T + R_short - Sqr_size, .L + R_long - For_cnt - 1) _ , Cells(.H - R_short + Sqr_size, .L + R_long - For_cnt - 1)) '左 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng For Each For_rng In Range(Cells(.T + R_short - Sqr_size, .W - R_long + For_cnt + 1) _ , Cells(.H - R_short + Sqr_size, .W - R_long + For_cnt + 1)) '右 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng Next For_cnt Else '縦長なら R_long = (.H - .T + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.W - .L + 1) \ 2 '短径 R_short2 = R_short * R_short If (.H - .T + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T + R_long, .L), Cells(.T + R_long, .W)) '中心 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng End If For For_cnt = 0 To R_long - 1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ For Each For_rng In Range(Cells(.T + R_long - For_cnt - 1, .L + R_short - Sqr_size) _ , Cells(.T + R_long - For_cnt - 1, .W - R_short + Sqr_size)) '上 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng For Each For_rng In Range(Cells(.H - R_long + For_cnt + 1, .L + R_short - Sqr_size) _ , Cells(.H - R_long + For_cnt + 1, .W - R_short + Sqr_size)) '下 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng Next For_cnt End If End With setLog '履歴取得 End Sub Public Sub paintCircleNotSub(Paint_ratio As Single) '●、副以外 Dim Rng As TERRITORY Dim For_rng As Range Dim R_long As Long, R_short As Long, R_long2 As Long, R_short2 As Long, Sqr_size As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = (.W - .L + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.H - .T + 1) \ 2 '短径 R_short2 = R_short * R_short If (.W - .L + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T, .L + R_long), Cells(.H, .L + R_long)) '中心 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng End If For For_cnt = 0 To R_long - 1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ For Each For_rng In Range(Cells(.T + R_short - Sqr_size, .L + R_long - For_cnt - 1) _ , Cells(.H - R_short + Sqr_size, .L + R_long - For_cnt - 1)) '左 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng For Each For_rng In Range(Cells(.T + R_short - Sqr_size, .W - R_long + For_cnt + 1) _ , Cells(.H - R_short + Sqr_size, .W - R_long + For_cnt + 1)) '右 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng Next For_cnt Else '縦長なら R_long = (.H - .T + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.W - .L + 1) \ 2 '短径 R_short2 = R_short * R_short If (.H - .T + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T + R_long, .L), Cells(.T + R_long, .W)) '中心 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng End If For For_cnt = 0 To R_long - 1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ For Each For_rng In Range(Cells(.T + R_long - For_cnt - 1, .L + R_short - Sqr_size) _ , Cells(.T + R_long - For_cnt - 1, .W - R_short + Sqr_size)) '上 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng For Each For_rng In Range(Cells(.H - R_long + For_cnt + 1, .L + R_short - Sqr_size) _ , Cells(.H - R_long + For_cnt + 1, .W - R_short + Sqr_size)) '下 If Rnd < Paint_ratio Then '乱数が濃度未満なら If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain End If End If Next For_rng Next For_cnt End If End With setLog '履歴取得 End Sub Public Sub paintCircleFrameAll(Width_size As Long) '○、全部 Dim Rng As TERRITORY, Pos0 As TERRITORY, Pos1 As TERRITORY Dim R_long As Long, R_short As Long, R_long2 As Long, R_short2 As Long, Sqr_size As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = (.W - .L + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.H - .T + 1) \ 2 '短径 R_short2 = R_short * R_short If R_short * 3 < Width_size * 4 Then '太さが短径の1/2より大きければ MsgBox "線の太さが大きすぎます" Exit Sub '帰る End If Pos0.T = .T + R_short '上 Pos0.L = .L + Width_size - 1 '左 Pos0.H = .H - R_short '下 Pos0.W = .W - Width_size + 1 '右 For For_cnt = R_long - 1 To 0 Step -1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ Pos1.T = .T + R_short - Sqr_size '上 Pos1.L = .L + R_long - For_cnt - 1 '左 Pos1.H = .H - R_short + Sqr_size '下 Pos1.W = .W - R_long + For_cnt + 1 '右 Range(Cells(Pos0.T, Pos0.L), Cells(Pos1.T, Pos1.L)).Interior.ColorIndex = Lng_PenColorMain '左上 Range(Cells(Pos0.H, Pos0.L), Cells(Pos1.H, Pos1.L)).Interior.ColorIndex = Lng_PenColorMain '左下 Range(Cells(Pos0.T, Pos0.W), Cells(Pos1.T, Pos1.W)).Interior.ColorIndex = Lng_PenColorMain '右上 Range(Cells(Pos0.H, Pos0.W), Cells(Pos1.H, Pos1.W)).Interior.ColorIndex = Lng_PenColorMain '右下 If Pos1.T + Width_size < .T + R_short Then Pos0.T = Pos1.T + Width_size - 1 '上 End If If Pos1.L + Width_size < .L + R_long + 1 Then Pos0.L = Pos1.L + Width_size '左 End If If .H - R_short < Pos1.H - Width_size Then Pos0.H = Pos1.H - Width_size + 1 '下 End If If .W - R_long - 1 < Pos1.W - Width_size Then Pos0.W = Pos1.W - Width_size '右 End If Next For_cnt If Width_size = 1 Then '太さ=1なら If (.W - .L + 1) Mod 2 Then '長径が奇数なら Range(Cells(.T, .L + R_long), Cells(.T + Width_size - 1, .L + R_long)) _ .Interior.ColorIndex = Lng_PenColorMain '上 Range(Cells(.H - Width_size + 1, .L + R_long), Cells(.H, .L + R_long)) _ .Interior.ColorIndex = Lng_PenColorMain '下 End If End If Else '縦長なら R_long = (.H - .T + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.W - .L + 1) \ 2 '短径 R_short2 = R_short * R_short If R_short * 3 < Width_size * 4 Then '太さが短径の1/2より大きければ MsgBox "太さが大きすぎます" Exit Sub '帰る End If Pos0.T = .T + Width_size - 1 '上 Pos0.L = .L + R_short '左 Pos0.H = .H - Width_size + 1 '下 Pos0.W = .W - R_short '右 For For_cnt = R_long - 1 To 0 Step -1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ Pos1.T = .T + R_long - For_cnt - 1 '上 Pos1.L = .L + R_short - Sqr_size '左 Pos1.H = .H - R_long + For_cnt + 1 '下 Pos1.W = .W - R_short + Sqr_size '右 Range(Cells(Pos0.T, Pos0.L), Cells(Pos1.T, Pos1.L)).Interior.ColorIndex = Lng_PenColorMain '左上 Range(Cells(Pos0.H, Pos0.L), Cells(Pos1.H, Pos1.L)).Interior.ColorIndex = Lng_PenColorMain '左下 Range(Cells(Pos0.T, Pos0.W), Cells(Pos1.T, Pos1.W)).Interior.ColorIndex = Lng_PenColorMain '右上 Range(Cells(Pos0.H, Pos0.W), Cells(Pos1.H, Pos1.W)).Interior.ColorIndex = Lng_PenColorMain '右下 If Pos1.T + Width_size < .T + R_long + 1 Then Pos0.T = Pos1.T + Width_size '上 End If If Pos1.L + Width_size < .L + R_short Then Pos0.L = Pos1.L + Width_size - 1 '左 End If If .H - R_long - 1 < Pos1.H - Width_size Then Pos0.H = Pos1.H - Width_size '下 End If If .W - R_short < Pos1.W - Width_size Then Pos0.W = Pos1.W - Width_size + 1 '右 End If Next For_cnt If Width_size = 1 Then '太さ=1なら If (.H - .T + 1) Mod 2 Then '長径が奇数なら Range(Cells(.T + R_long, .L), Cells(.T + R_long, .L + Width_size - 1)) _ .Interior.ColorIndex = Lng_PenColorMain '上 Range(Cells(.T + R_long, .W - Width_size + 1), Cells(.T + R_long, .W)) _ .Interior.ColorIndex = Lng_PenColorMain '下 End If End If End If End With setLog '履歴取得 End Sub Public Sub paintCircleFrameSubOnly(Width_size As Long) '○、副のみ Dim For_rng As Range Dim Rng As TERRITORY, Pos0 As TERRITORY, Pos1 As TERRITORY Dim R_long As Long, R_short As Long, R_long2 As Long, R_short2 As Long, Sqr_size As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = (.W - .L + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.H - .T + 1) \ 2 '短径 R_short2 = R_short * R_short If R_short * 3 < Width_size * 4 Then '太さが短径の1/2より大きければ MsgBox "線の太さが大きすぎます" Exit Sub '帰る End If Pos0.T = .T + R_short '上 Pos0.L = .L + Width_size - 1 '左 Pos0.H = .H - R_short '下 Pos0.W = .W - Width_size + 1 '右 For For_cnt = R_long - 1 To 0 Step -1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ Pos1.T = .T + R_short - Sqr_size '上 Pos1.L = .L + R_long - For_cnt - 1 '左 Pos1.H = .H - R_short + Sqr_size '下 Pos1.W = .W - R_long + For_cnt + 1 '右 For Each For_rng In Range(Cells(Pos0.T, Pos0.L), Cells(Pos1.T, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '左上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.L), Cells(Pos1.H, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '左下 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.T, Pos0.W), Cells(Pos1.T, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '右上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.W), Cells(Pos1.H, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '右下 End If End If Next For_rng If Pos1.T + Width_size < .T + R_short Then Pos0.T = Pos1.T + Width_size - 1 '上 End If If Pos1.L + Width_size < .L + R_long + 1 Then Pos0.L = Pos1.L + Width_size '左 End If If .H - R_short < Pos1.H - Width_size Then Pos0.H = Pos1.H - Width_size + 1 '下 End If If .W - R_long - 1 < Pos1.W - Width_size Then Pos0.W = Pos1.W - Width_size '右 End If Next For_cnt If Width_size = 1 Then '太さ=1なら If (.W - .L + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T, .L + R_long), Cells(.T + Width_size - 1, .L + R_long)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '上 End If End If Next For_rng For Each For_rng In Range(Cells(.H - Width_size + 1, .L + R_long), Cells(.H, .L + R_long)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '下 End If End If Next For_rng End If End If Else '縦長なら R_long = (.H - .T + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.W - .L + 1) \ 2 '短径 R_short2 = R_short * R_short If R_short * 3 < Width_size * 4 Then '太さが短径の1/2より大きければ MsgBox "太さが大きすぎます" Exit Sub '帰る End If Pos0.T = .T + Width_size - 1 '上 Pos0.L = .L + R_short '左 Pos0.H = .H - Width_size + 1 '下 Pos0.W = .W - R_short '右 For For_cnt = R_long - 1 To 0 Step -1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ Pos1.T = .T + R_long - For_cnt - 1 '上 Pos1.L = .L + R_short - Sqr_size '左 Pos1.H = .H - R_long + For_cnt + 1 '下 Pos1.W = .W - R_short + Sqr_size '右 For Each For_rng In Range(Cells(Pos0.T, Pos0.L), Cells(Pos1.T, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '左上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.L), Cells(Pos1.H, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '左下 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.T, Pos0.W), Cells(Pos1.T, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '右上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.W), Cells(Pos1.H, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '右下 End If End If Next For_rng If Pos1.T + Width_size < .T + R_long + 1 Then Pos0.T = Pos1.T + Width_size '上 End If If Pos1.L + Width_size < .L + R_short Then Pos0.L = Pos1.L + Width_size - 1 '左 End If If .H - R_long - 1 < Pos1.H - Width_size Then Pos0.H = Pos1.H - Width_size '下 End If If .W - R_short < Pos1.W - Width_size Then Pos0.W = Pos1.W - Width_size + 1 '右 End If Next For_cnt If Width_size = 1 Then '太さ=1なら If (.H - .T + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T + R_long, .L), Cells(.T + R_long, .L + Width_size - 1)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '上 End If End If Next For_rng For Each For_rng In Range(Cells(.T + R_long, .W - Width_size + 1), Cells(.T + R_long, .W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '下 End If End If Next For_rng End If End If End If End With setLog '履歴取得 End Sub Public Sub paintCircleFrameNotSub(Width_size As Long) '○、副以外 Dim For_rng As Range Dim Rng As TERRITORY, Pos0 As TERRITORY, Pos1 As TERRITORY Dim R_long As Long, R_short As Long, R_long2 As Long, R_short2 As Long, Sqr_size As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y 'カンバスサイズに補正 End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X 'カンバスサイズに補正 End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = (.W - .L + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.H - .T + 1) \ 2 '短径 R_short2 = R_short * R_short If R_short * 3 < Width_size * 4 Then '太さが短径の1/2より大きければ MsgBox "線の太さが大きすぎます" Exit Sub '帰る End If Pos0.T = .T + R_short '上 Pos0.L = .L + Width_size - 1 '左 Pos0.H = .H - R_short '下 Pos0.W = .W - Width_size + 1 '右 For For_cnt = R_long - 1 To 0 Step -1 '横方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'X軸方向の長さ Pos1.T = .T + R_short - Sqr_size '上 Pos1.L = .L + R_long - For_cnt - 1 '左 Pos1.H = .H - R_short + Sqr_size '下 Pos1.W = .W - R_long + For_cnt + 1 '右 For Each For_rng In Range(Cells(Pos0.T, Pos0.L), Cells(Pos1.T, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '左上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.L), Cells(Pos1.H, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '左下 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.T, Pos0.W), Cells(Pos1.T, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '右上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.W), Cells(Pos1.H, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '右下 End If End If Next For_rng If Pos1.T + Width_size < .T + R_short Then Pos0.T = Pos1.T + Width_size - 1 '上 End If If Pos1.L + Width_size < .L + R_long + 1 Then Pos0.L = Pos1.L + Width_size '左 End If If .H - R_short < Pos1.H - Width_size Then Pos0.H = Pos1.H - Width_size + 1 '下 End If If .W - R_long - 1 < Pos1.W - Width_size Then Pos0.W = Pos1.W - Width_size '右 End If Next For_cnt If Width_size = 1 Then '太さ=1なら If (.W - .L + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T, .L + R_long), Cells(.T + Width_size - 1, .L + R_long)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '上 End If End If Next For_rng For Each For_rng In Range(Cells(.H - Width_size + 1, .L + R_long), Cells(.H, .L + R_long)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '下 End If End If Next For_rng End If End If Else '縦長なら R_long = (.H - .T + 1) \ 2 '長径 R_long2 = R_long * R_long R_short = (.W - .L + 1) \ 2 '短径 R_short2 = R_short * R_short If R_short * 3 < Width_size * 4 Then '太さが短径の1/2より大きければ MsgBox "太さが大きすぎます" Exit Sub '帰る End If Pos0.T = .T + Width_size - 1 '上 Pos0.L = .L + R_short '左 Pos0.H = .H - Width_size + 1 '下 Pos0.W = .W - R_short '右 For For_cnt = R_long - 1 To 0 Step -1 '縦方向繰り返し Sqr_size = CLng(Sqr((R_long2 - For_cnt * For_cnt) / R_long2 * R_short2)) 'Y軸方向の長さ Pos1.T = .T + R_long - For_cnt - 1 '上 Pos1.L = .L + R_short - Sqr_size '左 Pos1.H = .H - R_long + For_cnt + 1 '下 Pos1.W = .W - R_short + Sqr_size '右 For Each For_rng In Range(Cells(Pos0.T, Pos0.L), Cells(Pos1.T, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '左上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.L), Cells(Pos1.H, Pos1.L)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '左下 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.T, Pos0.W), Cells(Pos1.T, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '右上 End If End If Next For_rng For Each For_rng In Range(Cells(Pos0.H, Pos0.W), Cells(Pos1.H, Pos1.W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '右下 End If End If Next For_rng If Pos1.T + Width_size < .T + R_long + 1 Then Pos0.T = Pos1.T + Width_size '上 End If If Pos1.L + Width_size < .L + R_short Then Pos0.L = Pos1.L + Width_size - 1 '左 End If If .H - R_long - 1 < Pos1.H - Width_size Then Pos0.H = Pos1.H - Width_size '下 End If If .W - R_short < Pos1.W - Width_size Then Pos0.W = Pos1.W - Width_size + 1 '右 End If Next For_cnt If Width_size = 1 Then '太さ=1なら If (.H - .T + 1) Mod 2 Then '長径が奇数なら For Each For_rng In Range(Cells(.T + R_long, .L), Cells(.T + R_long, .L + Width_size - 1)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '上 End If End If Next For_rng For Each For_rng In Range(Cells(.T + R_long, .W - Width_size + 1), Cells(.T + R_long, .W)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '下 End If End If Next For_rng End If End If End If End With setLog '履歴取得 End Sub Public Sub paintSlashAll(Width_size As Long, BackIs_True As Boolean) '斜線、全部 Dim Rng As TERRITORY Dim R_long As Long, R_short As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = .W - .L - Width_size + 1 '長径 R_short = .H - .T - Width_size + 2 '短径 If R_short < 1 Then '太さが短い幅以上なら MsgBox "太さが大きすぎます" & Chr(10) _ & Chr(10) & "範囲：1〜" & CStr(.H - .T) Exit Sub '帰る End If If BackIs_True Then 'バックスラッシュなら For For_cnt = 1 To R_short '短径を繰り返し Range(Cells(.T + For_cnt - 1, .L + CLng(R_long * (For_cnt - 1) / R_short)) _ , Cells(.T + For_cnt + Width_size - 2, .L + CLng(R_long * For_cnt / R_short) + Width_size - 1)) _ .Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし Next For_cnt Else For For_cnt = 1 To R_short '短径を繰り返し Range(Cells(.T + For_cnt - 1, .W - CLng(R_long * (For_cnt - 1) / R_short)) _ , Cells(.T + For_cnt + Width_size - 2, .W - CLng(R_long * For_cnt / R_short) - Width_size + 1)) _ .Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし Next For_cnt End If Else '縦長なら R_long = .H - .T - Width_size + 1 '長径 R_short = .W - .L - Width_size + 2 '短径 If R_short < 1 Then '太さが短い幅以上なら MsgBox "太さが大きすぎます" & Chr(10) _ & Chr(10) & "範囲：1〜" & CStr(.H - .T) Exit Sub '帰る End If If BackIs_True Then 'バックスラッシュなら For For_cnt = 1 To R_short '短径を繰り返し Range(Cells(.T + CLng(R_long * (For_cnt - 1) / R_short), .L + For_cnt - 1) _ , Cells(.T + CLng(R_long * For_cnt / R_short) + Width_size - 1, .L + For_cnt + Width_size - 2)) _ .Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし Next For_cnt Else For For_cnt = 1 To R_short '短径を繰り返し Range(Cells(.H - CLng(R_long * (For_cnt - 1) / R_short), .L + For_cnt - 1) _ , Cells(.H - CLng(R_long * For_cnt / R_short) - Width_size + 1, .L + For_cnt + Width_size - 2)) _ .Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし Next For_cnt End If End If End With setLog '履歴取得 End Sub Public Sub paintSlashSubOnly(Width_size As Long, BackIs_True As Boolean) '斜線、副のみ Dim For_rng As Range Dim Rng As TERRITORY Dim R_long As Long, R_short As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = .W - .L - Width_size + 1 '長径 R_short = .H - .T - Width_size + 2 '短径 If R_short < 1 Then '太さが短い幅以上なら MsgBox "太さが大きすぎます" & Chr(10) _ & Chr(10) & "範囲：1〜" & CStr(.H - .T) Exit Sub '帰る End If If BackIs_True Then 'バックスラッシュなら For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.T + For_cnt - 1, .L + CLng(R_long * (For_cnt - 1) / R_short)) _ , Cells(.T + For_cnt + Width_size - 2, .L + CLng(R_long * For_cnt / R_short) + Width_size - 1)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt Else For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.T + For_cnt - 1, .W - CLng(R_long * (For_cnt - 1) / R_short)) _ , Cells(.T + For_cnt + Width_size - 2, .W - CLng(R_long * For_cnt / R_short) - Width_size + 1)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt End If Else '縦長なら R_long = .H - .T - Width_size + 1 '長径 R_short = .W - .L - Width_size + 2 '短径 If R_short < 1 Then '太さが短い幅以上なら MsgBox "太さが大きすぎます" & Chr(10) _ & Chr(10) & "範囲：1〜" & CStr(.H - .T) Exit Sub '帰る End If If BackIs_True Then 'バックスラッシュなら For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.T + CLng(R_long * (For_cnt - 1) / R_short), .L + For_cnt - 1) _ , Cells(.T + CLng(R_long * For_cnt / R_short) + Width_size - 1, .L + For_cnt + Width_size - 2)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt Else For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.H - CLng(R_long * (For_cnt - 1) / R_short), .L + For_cnt - 1) _ , Cells(.H - CLng(R_long * For_cnt / R_short) - Width_size + 1, .L + For_cnt + Width_size - 2)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex = Lng_PenColorSub Then '副の色なら For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt End If End If End With setLog '履歴取得 End Sub Public Sub paintSlashNotSub(Width_size As Long, BackIs_True As Boolean) '斜線、副以外 Dim For_rng As Range Dim Rng As TERRITORY Dim R_long As Long, R_short As Long, For_cnt As Long If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With With Rng If PAP_CanvasSize.Y < .H Then '終了行番号がカンバスを超えていれば .H = PAP_CanvasSize.Y End If If PAP_CanvasSize.X < .W Then '終了列番号がカンバスを超えていれば .W = PAP_CanvasSize.X End If If .H - .T + 1 < .W - .L + 1 Then '横長なら R_long = .W - .L - Width_size + 1 '長径 R_short = .H - .T - Width_size + 2 '短径 If R_short < 1 Then '太さが短い幅以上なら MsgBox "太さが大きすぎます" & Chr(10) _ & Chr(10) & "範囲：1〜" & CStr(.H - .T) Exit Sub '帰る End If If BackIs_True Then 'バックスラッシュなら For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.T + For_cnt - 1, .L + CLng(R_long * (For_cnt - 1) / R_short)) _ , Cells(.T + For_cnt + Width_size - 2, .L + CLng(R_long * For_cnt / R_short) + Width_size - 1)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt Else For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.T + For_cnt - 1, .W - CLng(R_long * (For_cnt - 1) / R_short)) _ , Cells(.T + For_cnt + Width_size - 2, .W - CLng(R_long * For_cnt / R_short) - Width_size + 1)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt End If Else '縦長なら R_long = .H - .T - Width_size + 1 '長径 R_short = .W - .L - Width_size + 2 '短径 If R_short < 1 Then '太さが短い幅以上なら MsgBox "太さが大きすぎます" & Chr(10) _ & Chr(10) & "範囲：1〜" & CStr(.H - .T) Exit Sub '帰る End If If BackIs_True Then 'バックスラッシュなら For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.T + CLng(R_long * (For_cnt - 1) / R_short), .L + For_cnt - 1) _ , Cells(.T + CLng(R_long * For_cnt / R_short) + Width_size - 1, .L + For_cnt + Width_size - 2)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt Else For For_cnt = 1 To R_short '短径を繰り返し For Each For_rng In Range(Cells(.H - CLng(R_long * (For_cnt - 1) / R_short), .L + For_cnt - 1) _ , Cells(.H - CLng(R_long * For_cnt / R_short) - Width_size + 1, .L + For_cnt + Width_size - 2)) If For_rng.Interior.ColorIndex <> Lng_PenColorMain Then '主の色でなければ If For_rng.Interior.ColorIndex <> Lng_PenColorSub Then '副の色でなければ For_rng.Interior.ColorIndex = Lng_PenColorMain '主の色で塗りつぶし End If End If Next For_rng Next For_cnt End If End If End With setLog '履歴取得End Sub End Sub Public Sub paintShadeAll(Paint_ratio As Single, Width_size As Long) 'ぼかし、全部 Dim SHD0 As POINTAPI, SHD1 As POINTAPI Dim Rng As TERRITORY Dim For_cnt As Long, For_r As Long, For_c As Long If Width_size * Width_size * Paint_ratio < 1 Then '太さが1以下なら MsgBox "濃度が低すぎます" Exit Sub '帰る End If If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With If PAP_CanvasSize.Y < Rng.H Then '終了行番号がカンバスを超えていれば Rng.H = PAP_CanvasSize.Y End If If PAP_CanvasSize.X < Rng.W Then '終了列番号がカンバスを超えていれば Rng.W = PAP_CanvasSize.X End If For For_r = Rng.T To Rng.H Step CLng(Width_size * 0.75) '行を繰り返し(ぼかし幅の0.25ずつを交差) For For_c = Rng.L To Rng.W Step CLng(Width_size * 0.75) '列を繰り返し(ぼかし幅の0.25ずつを交差) For For_cnt = 1 To Width_size * Width_size * Paint_ratio SHD0.Y = Int(Rnd * Width_size) 'ぼかし元の行 SHD0.X = Int(Rnd * Width_size) 'ぼかし元の列 SHD1.Y = Int(Rnd * Width_size) 'ぼかし先の行 SHD1.X = Int(Rnd * Width_size) 'ぼかし先の列 If For_r + SHD0.Y <= Rng.H And For_c + SHD0.X <= Rng.W Then 'ぼかし元が範囲内なら If For_r + SHD1.Y <= Rng.H And For_c + SHD1.X <= Rng.W Then 'ぼかし先が範囲内なら If Cells(For_r + SHD0.Y, For_c + SHD0.X).Interior.ColorIndex _ <> Cells(For_r + SHD1.Y, For_c + SHD1.X).Interior.ColorIndex Then 'ぼかし元と先が違う色なら Cells(For_r + SHD1.Y, For_c + SHD1.X).Interior.ColorIndex _ = Cells(For_r + SHD0.Y, For_c + SHD0.X).Interior.ColorIndex 'ぼかし End If End If End If Next For_cnt Next For_c Next For_r setLog '履歴取得 End Sub Public Sub paintShadeSubOnly(Paint_ratio As Single, Width_size As Long) 'ぼかし、副のみ Dim SHD0 As POINTAPI, SHD1 As POINTAPI Dim Rng As TERRITORY Dim For_cnt As Long, For_r As Long, For_c As Long, Clr_shd0 As Long, Clr_shd1 As Long If Width_size * Width_size * Paint_ratio < 1 Then '太さが1以下なら MsgBox "濃度が低すぎます" Exit Sub '帰る End If If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With If PAP_CanvasSize.Y < Rng.H Then '終了行番号がカンバスを超えていれば Rng.H = PAP_CanvasSize.Y End If If PAP_CanvasSize.X < Rng.W Then '終了列番号がカンバスを超えていれば Rng.W = PAP_CanvasSize.X End If For For_r = Rng.T To Rng.H Step CLng(Width_size * 0.75) '行を繰り返し(ぼかし幅の0.25ずつを交差) For For_c = Rng.L To Rng.W Step CLng(Width_size * 0.75) '列を繰り返し(ぼかし幅の0.25ずつを交差) For For_cnt = 1 To Width_size * Width_size * Paint_ratio SHD0.Y = Int(Rnd * Width_size) 'ぼかし元の行 SHD0.X = Int(Rnd * Width_size) 'ぼかし元の列 SHD1.Y = Int(Rnd * Width_size) 'ぼかし先の行 SHD1.X = Int(Rnd * Width_size) 'ぼかし先の列 If For_r + SHD0.Y <= Rng.H And For_c + SHD0.X <= Rng.W Then 'ぼかし元が範囲内なら If For_r + SHD1.Y <= Rng.H And For_c + SHD1.X <= Rng.W Then 'ぼかし先が範囲内なら Clr_shd0 = Cells(For_r + SHD0.Y, For_c + SHD0.X).Interior.ColorIndex 'ぼかし元 Clr_shd1 = Cells(For_r + SHD1.Y, For_c + SHD1.X).Interior.ColorIndex 'ぼかし先 If Clr_shd0 <> Clr_shd1 Then 'ぼかし元と先が違う色なら If Clr_shd0 = Lng_PenColorSub Then 'ぼかし元が副の色なら Cells(For_r + SHD1.Y, For_c + SHD1.X).Interior.ColorIndex = Clr_shd0 'ぼかし End If End If End If End If Next For_cnt Next For_c Next For_r setLog '履歴取得 End Sub Public Sub paintShadeNotSub(Paint_ratio As Single, Width_size As Long) 'ぼかし、副以外 Dim SHD0 As POINTAPI, SHD1 As POINTAPI Dim Rng As TERRITORY Dim For_cnt As Long, For_r As Long, For_c As Long, Clr_shd0 As Long, Clr_shd1 As Long If Width_size * Width_size * Paint_ratio < 1 Then '太さが1以下なら MsgBox "濃度が低すぎます" Exit Sub '帰る End If If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '開始行番号 Rng.L = .Column '開始列番号 Rng.H = Rng.T + .Rows.Count - 1 '終了行番号 Rng.W = Rng.L + .Columns.Count - 1 '終了列番号 End With If PAP_CanvasSize.Y < Rng.H Then '終了行番号がカンバスを超えていれば Rng.H = PAP_CanvasSize.Y End If If PAP_CanvasSize.X < Rng.W Then '終了列番号がカンバスを超えていれば Rng.W = PAP_CanvasSize.X End If For For_r = Rng.T To Rng.H Step CLng(Width_size * 0.75) '行を繰り返し(ぼかし幅の0.25ずつを交差) For For_c = Rng.L To Rng.W Step CLng(Width_size * 0.75) '列を繰り返し(ぼかし幅の0.25ずつを交差) For For_cnt = 1 To Width_size * Width_size * Paint_ratio SHD0.Y = Int(Rnd * Width_size) 'ぼかし元の行 SHD0.X = Int(Rnd * Width_size) 'ぼかし元の列 SHD1.Y = Int(Rnd * Width_size) 'ぼかし先の行 SHD1.X = Int(Rnd * Width_size) 'ぼかし先の列 If For_r + SHD0.Y <= Rng.H And For_c + SHD0.X <= Rng.W Then 'ぼかし元が範囲内なら If For_r + SHD1.Y <= Rng.H And For_c + SHD1.X <= Rng.W Then 'ぼかし先が範囲内なら Clr_shd0 = Cells(For_r + SHD0.Y, For_c + SHD0.X).Interior.ColorIndex 'ぼかし元 Clr_shd1 = Cells(For_r + SHD1.Y, For_c + SHD1.X).Interior.ColorIndex 'ぼかし先 If Clr_shd0 <> Clr_shd1 Then 'ぼかし元と先が違う色なら If Clr_shd0 <> Lng_PenColorSub Then 'ぼかし元が副の色でなければ If Clr_shd1 <> Lng_PenColorSub Then 'ぼかし先が副の色でなければ Cells(For_r + SHD1.Y, For_c + SHD1.X).Interior.ColorIndex = Clr_shd0 'ぼかし End If End If End If End If End If Next For_cnt Next For_c Next For_r setLog '履歴取得 End Sub '■クリップ Public Sub setClip(Clip_no As Long) 'クリップをセット With SheetClip If .Cells(ModuleConst.CLIPSIZE_Y, Clip_no + 1) = "" Or .Cells(ModuleConst.CLIPSIZE_X, Clip_no + 1) = "" Then PAP_ClipSize.Y = 1 '行数 PAP_ClipSize.X = 1 '列数 Else PAP_ClipSize.Y = .Cells(ModuleConst.CLIPSIZE_Y, Clip_no + 1) '行数 PAP_ClipSize.X = .Cells(ModuleConst.CLIPSIZE_X, Clip_no + 1) '列数 End If Set Rng_Clip = SheetClip.Cells((Clip_no + 2) * PAP_CanvasMax.Y + 1, 1) _ .Resize(PAP_ClipSize.Y, PAP_ClipSize.X) End With End Sub Public Function getClipSize(YisF_XisT As Boolean) As Long 'クリップの大きさを取得 If YisF_XisT Then getClipSize = PAP_ClipSize.X '横 Else getClipSize = PAP_ClipSize.Y '縦 End If End Function Public Sub addClip(Clip_no As Long) 'クリップ登録 Dim Rng As TERRITORY If TypeName(Selection) <> "Range" Then 'セルが選択されていなければ Exit Sub '帰る End If With Selection Rng.T = .Row '左上行番号 Rng.L = .Column '左上の列番号 Rng.H = .Rows.Count '行幅 Rng.W = .Columns.Count '列幅 End With With Rng If judgeCanvasIn(Rng.T, Rng.L) _ And judgeCanvasIn(Rng.H + Rng.T - 1, Rng.W + Rng.L - 1) Then 'セル範囲がカンバス内なら Rng_Clip.Clear '元のクリップをクリア With SheetClip Cells(Rng.T, Rng.L).Resize(Rng.H, Rng.W) _ .Copy .Cells((Clip_no + 2) * PAP_CanvasMax.Y + 1, 1) 'クリップをコピー Set Rng_Clip = .Cells((Clip_no + 2) * PAP_CanvasMax.Y + 1, 1).Resize(PAP_ClipSize.Y, PAP_ClipSize.X) PAP_ClipSize.Y = Rng.H 'クリップサイズ(縦) PAP_ClipSize.X = Rng.W 'クリップサイズ(横) .Cells(ModuleConst.CLIPSIZE_Y, Clip_no + 1) = PAP_ClipSize.Y '情報を保存 .Cells(ModuleConst.CLIPSIZE_X, Clip_no + 1) = PAP_ClipSize.X '情報を保存 End With Else MsgBox "選択範囲がカンバスを超えています" End If End With End Sub Public Sub checkClip(Clip_no As Long) 'クリップ確認 Dim Yx As POINTAPI Dim Zoom_size As Long Dim Grid_flg As Boolean Yx.Y = CLng(Val(SheetClip.Cells(ModuleConst.CLIPSIZE_Y, Clip_no + 1))) Yx.X = CLng(Val(SheetClip.Cells(ModuleConst.CLIPSIZE_X, Clip_no + 1))) If Yx.Y < 1 Or Yx.X < 1 Then 'クリップがなければ MsgBox "クリップが登録されていません" Else Application.ScreenUpdating = False '画面更新オフ With SheetClip .Cells.RowHeight = Cells(1).RowHeight 'カンバスの縦に合わせる .Cells.ColumnWidth = Cells(1).ColumnWidth 'カンバスの横に合わせる .Visible = True '表示 With ActiveWindow Zoom_size = .Zoom 'カンバスのズーム Grid_flg = .DisplayGridlines 'グリッド線 SheetClip.Activate .Zoom = Zoom_size 'カンバスのズームに合わせる .DisplayGridlines = Grid_flg 'グリッド線 .ScrollRow = Rng_Clip.Row '上端セルをクリップの上端セルに合わせる .ScrollColumn = 1 '左端セルをクリップの左端セルに合わせる End With Application.ScreenUpdating = True '画面更新オン MsgBox "クリップ名：" & SheetClip.Cells(ModuleConst.CLIPNAME, Clip_no + 1) & Chr(10) _ & "縦サイズ：" & Yx.Y & Chr(10) _ & "横サイズ：" & Yx.X SheetCanvas.Activate 'カンバスシートをアクティブ .Visible = False '非表示 End With End If End Sub Public Sub putClip(ClearIs_true) 'カンバス反映 SheetCanvas.Activate If ClearIs_true Then 'クリアして反映なら Cells.Clear End If Rng_Clip.Copy Cells(1, 1) setLog '履歴取得 End Sub Public Sub deleteClip(Optional Clip_no As Long = -1) 'クリップ削除 If Clip_no = -1 Then '全削除なら With SheetClip .Rows(PAP_CanvasMax.Y * 2 + 1).Resize(PAP_CanvasMax.Y * 20).Clear '全削除 .Rows(ModuleConst.CLIPSIZE_Y).Clear '縦の大きさ .Rows(ModuleConst.CLIPSIZE_X).Clear '横の大きさ End With Else Rng_Clip.Clear 'ひとつ削除 With SheetClip .Cells(ModuleConst.CLIPSIZE_Y, Clip_no + 1).Clear '縦の大きさ .Cells(ModuleConst.CLIPSIZE_X, Clip_no + 1).Clear '横の大きさ End With End If Set Rng_Clip = Rng_Clip(1, 1) '縦1横1のサイズに縮小 PAP_ClipSize.Y = 1 'クリップサイズ(縦) PAP_ClipSize.X = 1 'クリップサイズ(横) End Sub Public Sub composeClip(Clip_list As Variant, UpIs_true) 'クリップ合成 Dim Rc As POINTAPI, Yx As POINTAPI Dim List_size As Long, Update_row As Long, For_cnt As Long, For_r As Long, For_c As Long List_size = UBound(Clip_list) - 1 Yx.Y = 1 Yx.X = 1 Update_row = 100 '100行ごとに画面更新 Application.ScreenUpdating = False '画面更新オフ With SheetClip For For_cnt = 0 To List_size '要素数繰り返し Rc.Y = CLng(Val(.Cells(ModuleConst.CLIPSIZE_Y, Clip_list(For_cnt) + 1))) If Yx.Y < Rc.Y Then 'クリップサイズが大きければ Yx.Y = Rc.Y '縦の最大値 End If Rc.X = CLng(Val(.Cells(ModuleConst.CLIPSIZE_X, Clip_list(For_cnt) + 1))) If Yx.X < Rc.X Then 'クリップサイズが大きければ Yx.X = Rc.X '横の最大値 End If Next For_cnt If UpIs_true Then 'カンバスの上に合成 For For_r = 1 To Yx.Y If For_r = Update_row Then '100行ごと Application.ScreenUpdating = True '画面更新オン Update_row = Update_row + 100 '次の100行 Application.ScreenUpdating = False '画面更新オフ End If For For_c = 1 To Yx.X For For_cnt = 0 To List_size '要素数繰り返し If .Cells((Clip_list(For_cnt) + 2) * PAP_CanvasMax.Y + For_r, For_c) _ .Interior.ColorIndex <> -4142 Then '塗りつぶしなしでなければ Cells(For_r, For_c).Interior.ColorIndex _ = .Cells((Clip_list(For_cnt) + 2) * PAP_CanvasMax.Y + For_r, For_c).Interior.ColorIndex Exit For End If Next For_cnt If GetAsyncKeyState(vbKeyC) Then '[C]キーが押されていれば For_r = Yx.Y + 1 For_c = Yx.X + 1 MsgBox "中断しました" End If Next For_c Next For_r Else 'カンバスの下に合成 For For_r = 1 To Yx.Y If For_r = Update_row Then '100行ごと Application.ScreenUpdating = True '画面更新オン Update_row = Update_row + 100 '次の100行 Application.ScreenUpdating = False '画面更新オフ End If For For_c = 1 To Yx.X For For_cnt = 0 To List_size '要素数繰り返し If Cells(For_r, For_c).Interior.ColorIndex = -4142 Then '塗りつぶしなしなら If .Cells((Clip_list(For_cnt) + 2) * PAP_CanvasMax.Y + For_r, For_c) _ .Interior.ColorIndex <> -4142 Then '塗りつぶしなしでなければ Cells(For_r, For_c).Interior.ColorIndex _ = .Cells((Clip_list(For_cnt) + 2) * PAP_CanvasMax.Y + For_r, For_c).Interior.ColorIndex Exit For End If End If Next For_cnt If GetAsyncKeyState(vbKeyC) Then '[C]キーが押されていれば For_r = Yx.Y + 1 For_c = Yx.X + 1 MsgBox "中断しました" End If Next For_c Next For_r End If End With Application.ScreenUpdating = True '画面更新オン setLog '履歴取得 End Sub