エクセルで大きな表を作成した時に、表に数字を入れる場合、行と列を間違えて入力してしまうことがあります。それを防止するためにあるマクロが動いているあいだは、マウスがオーバーする行、列のセルに色を付けるようなマクロを作ろうかと考えました。(セルなどをクリックしなくても、マウスが移動すれば、マウスがかかっているセルの行と列に色がついてまわる)単純に、MauseMoveイベントで処理って思いつきましたが、対象がグラフにしかありません。で、途方にくれました。また、仮に、イベントの処理方法が判ったとしても、単純にセルに色をつけたり消したりしたのでは、元々表に色が付いていた場合、消して回ることになります。なにか?どのようにすれば実現が可能でしょうか?イメージ的には、CADなどでX軸とY軸に垂線と水平線がカーソルについて回るって感じです。
最大の問題は、カーソルが通り過ぎた時に元々の色に戻すっててんだと思いますが、どなたか?詳しい方がイラッシャイましたら教えて頂けないでしょうか?
宜しくお願い致します。
No.5ベストアンサー
- 回答日時:
こんにちは。
KenKen_SP です。> #案外実用的かも^ ^
すみません。やっぱり、#3 はうまくいかないみたいです。Excel で CallBack
プロシージャを使うとコードに一見問題がないように見えても、何故か数秒後
にフリーズしたりして非常に苦労するのですが、今回は結構動いてたので、
調子にのって投稿してしまいました。しかし、しばらくほっとくと、フリーズ
こそしないのですが、CallBack されなくなって動かなくなります。これでは
使い物にならないですね...
いろいろ調整してみましたが、(私のスキルでは)実用不可でした。
少し真面目に実用に耐え得るコードを書いてみました。こっちの方がご質問の
ご希望に近いかもしれません。
#3 と同じように、ユーザーフォームにトグルを一つ貼り付けて、コードをコピペ
して下さい。今度はフォームモジュールのみで完結させてます。
このフォームを vbModeless で呼び出すか、VBE のフォームの ShowModal プロパ
ティーの値を False にしておきます。
' ソースコード(フォームモジュール)------------------------------------
Option Explicit
Private mLineHT As Shape, mLineHB As Shape
Private mLineVL As Shape, mLineVR As Shape
Private Const BASENAME As String = "$CurLine_$"
Private Const MARJIN As Single = 500
Private Const LINE_WEIGHT As Single = 1.5 ’線の太さをPtで設定
Private WithEvents xlApp As Application
Private mSh As Worksheet
Private Sub UserForm_Initialize()
' 初期化
With Me
.StartUpPosition = 0 ' Manual
.Width = 80: .Height = 40
.Caption = "Line Cursol"
' 初期表示位置(適当に修正して下さい)
.Top = ActiveWindow.Top + 120
.Left = ActiveWindow.Width - .Width - 40
End With
With Me.ToggleButton1
.Top = 0: .Left = 0
.Width = Me.InsideWidth: .Height = Me.InsideHeight
.Caption = "On"
End With
Set xlApp = Application
Set mSh = ActiveSheet
Exit Sub
ERROR_HANDLER:
MsgBox Err.Description, vbExclamation
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Call Lines_Del(True)
Set mSh = Nothing
Set xlApp = Nothing
End Sub
Private Sub ToggleButton1_Change()
Dim i As Long
With Me.ToggleButton1
If .Value Then
.Caption = "On"
Call Lines_Add
Else
.Caption = "Off"
Call Lines_Del
End If
End With
End Sub
Private Sub Lines_Add()
On Error Resume Next
Application.ScreenUpdating = False
If Not mSh Is ActiveSheet Then
Call Lines_Del
Set mSh = ActiveSheet
End If
Call Lines_Del
With ActiveCell.MergeArea
Set mLineHT = sp_DrawLine(.Top)
Set mLineVL = sp_DrawLine(, .Left)
Set mLineHB = sp_DrawLine(.Top + .Height)
Set mLineVR = sp_DrawLine(, .Left + .Width)
End With
End Sub
Private Sub Lines_Del(Optional ByVal ALL_LINES As Boolean)
Dim Wb As Workbook
Dim Sh As Worksheet
Dim shpLine As Shape
If Not ALL_LINES Then
On Error GoTo ALL_LINES_DELETE
mLineHT.Delete: mLineHB.Delete
mLineVL.Delete: mLineVR.Delete
Else
ALL_LINES_DELETE:
On Error Resume Next
For Each Wb In Workbooks
For Each Sh In Wb.Worksheets
For Each shpLine In Sh.Shapes
If shpLine.Name Like BASENAME & "*" Then
shpLine.Delete
End If
Next shpLine
Next Sh
Next Wb
End If
Set mLineHT = Nothing: Set mLineHB = Nothing
Set mLineVL = Nothing: Set mLineVR = Nothing
On Error GoTo 0
End Sub
Private Function sp_DrawLine( _
Optional ByVal sglT As Single, _
Optional ByVal sglL As Single) As Shape
Dim sglW As Single
Dim sglH As Single
sglW = Columns(Columns.Count).Left + MARJIN
sglH = Rows(Rows.Count).Top + MARJIN
If sglL = 0 And sglT >= 0 Then
Set sp_DrawLine = ActiveSheet.Shapes.AddLine(0#, sglT, sglW, sglT)
ElseIf sglT = 0 And sglL >= 0 Then
Set sp_DrawLine = ActiveSheet.Shapes.AddLine(sglL, 0#, sglL, sglH)
Else
Err.Raise 1000, , "sp_DrawLine 関数に不正パラメータが渡されました."
End If
With sp_DrawLine
.Name = BASENAME & .Name
.Line.Weight = LINE_WEIGHT
.Line.Style = msoLineSingle
.Line.ForeColor.SchemeColor = 48
End With
End Function
Private Sub xlApp_SheetActivate(ByVal Sh As Object)
If Me.ToggleButton1.Value Then
Call Lines_Add
End If
End Sub
Private Sub xlApp_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Me.ToggleButton1.Value Then
Call Lines_Add
End If
End Sub
Private Sub xlApp_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean)
Call Lines_Del
End Sub
Private Sub xlApp_WorkbookBeforeSave(ByVal Wb As Workbook, ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call Lines_Del
End Sub
No.4
- 回答日時:
こんにちは。
KenKen_SPさん、スゴいですね。勉強になります。ありがとうございました。m(_ _)m
私の環境でも使用できました。(win2000/xl2000)
他のwinXP/xl2003にもDirectX8は入ってましたので、
使える環境は多いのではないでしょうか。
#案外実用的かも^ ^
>vba_minaraiさんへ
蛇足ながら、Zoom補正ですが
Option Explicit
Private sx As Single
Private sy As Single
Sub 補正()
Dim rng As Range
With ActiveSheet
On Error Resume Next
.Ovals("oval_S").Delete
On Error GoTo 0
Set rng = .Range("IV65536")
Application.Goto rng
With .Shapes.AddShape(msoShapeOval, rng.Left - 4, rng.Top - 4, 8, 8)
.Name = "oval_S"
.Fill.ForeColor.SchemeColor = 10
.OnAction = "center_click"
End With
End With
Set rng = Nothing
MsgBox "最終セルの赤丸 Click"
End Sub
Sub center_click()
Dim xi As Single, yi As Single, n As Long
On Error Resume Next
Call GetCursorPos(MoP)
With ActiveWindow
n = .Zoom
xi = (MoP.X - .PointsToScreenPixelsX(Range("A1").Left)) * 300 / (4 * n)
yi = (MoP.Y - .PointsToScreenPixelsY(Range("A1").Top)) * 300 / (4 * n)
End With
With ActiveSheet.Ovals("oval_S")
sx = .Left / xi
sy = .Top / yi
.Delete
End With
MsgBox "ok: " & sx & " / " & sy
Application.Goto Range("A1")
End Sub
...と係数になるようなものを取得しておいて
With ActiveWindow
n = .Zoom
Ln = (MoP.X - .PointsToScreenPixelsX(Range("A1").Left)) * 300 / (4 * n) * sx
Tn = (MoP.Y - .PointsToScreenPixelsY(Range("A1").Top)) * 300 / (4 * n) * sy
End With
...とすればいいかもしれません。
もしかしたら自動で取得できるのかもしれませんが、わかりませんでした^ ^;
(どこかでsxとsyの初期値を1にする処理が必要)
(* 300 / (4 * n) は元の * 3 / 4 にZoomの%を掛け合わせただけです)
また、セル選択を考慮するなら
.Left = Ln + 3
.Top = Tn + 4
などと少し調整したほうがいいかもしれませんね。
No.3
- 回答日時:
こんにちは。
KenKen_SP です。本来は、外部のツールを使った方が良いのかもしれません。
アイディアと一部コードは #1 の pauNed さんのものをお借りしましたm(_ _)m
Do ~ Loop でマウスの位置を監視する方法だとキー入力がうまくできなかった
ので、DirectInput を使ってみました。CPU 負荷はマウスを動かしているとき
だけかかります。ただし、それなりにマシンスペックは必要です。
テスト環境は WindowsXP + DirectX8 + Excel2002 です。
また、私の PC には Visual Basic 6.0 がインストールされているのですが、
他環境ではテストしてません。きっと、VB がインストールされないとダメな気
がしますね...環境を著しく限定させてしまい実用的ではないです。
エラートラップはしてありますが、挙動不信なときもあるので、テストコード
扱いです。いきなり Excel がフリーズするかもしれません。十分ご注意下さい。
このような状況に加え、コメントはほぼ入れてませんし、コードの解説もできま
せんので、この場で公開できるものなのか悩みましたが、面白そうなので参加し
ちゃいます。
【手順】
0. VBE で DirextX x Visual Basic Type Library を参照設定
1. フォーム(Userform1)、標準モジュールをそれぞれ挿入
2. フォームに ToggleButton1 を配置
3. 以下のコードをそれぞれの場所にコピペ
4. Userform1 を下記のコードで開く
Userform1.Show vbModeless
それにしても....長すぎですね、すみませんm(_ _)m
【以下ソースコード】
'----------------- Userform1 フォームモジュール -----------------
Option Explicit
' 要参照設定 DirextX x Visual Basic Type Library
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
lpPoint As POINTAPI _
) As Long
Private Declare Function SetActiveWindow Lib "user32.dll" ( _
ByVal hwnd As Long _
) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private MoP As POINTAPI
Private mhWnd As Long
Private mSh As Worksheet
Private mLine_H As Shape
Private mLine_V As Shape
' DirectInput
Implements DirectXEvent8
Private mDX As DirectX8
Private mDI As DxVBLibA.DirectInput8
Private mDIDevM As DxVBLibA.DirectInputDevice8
Private mhEventM As Long
Private Const MAX_BUFFERSIZE As Long = 10
'
Private Sub UserForm_Initialize()
' フォーム・コントロールの初期化
With Me
.Width = 80: .Height = 40
End With
With Me.ToggleButton1
.Top = 0: .Left = 0
.Width = Me.InsideWidth: .Height = Me.InsideHeight
.Caption = "Cross Cursol Off"
End With
On Error GoTo ERROR_HANDLER
' Userform のウインドウハンドル
mhWnd = FindWindow("ThunderDFrame", Me.Caption)
If mhWnd > 0 Then
Call InitDirextInput
Else
Err.Raise 1000, , "Userform の hWnd が取得できませんでした"
Unload Me
End If
Set mSh = ActiveSheet
Exit Sub
ERROR_HANDLER:
Set mDIDevM = Nothing
Set mDI = Nothing
Set mDX = Nothing
Set mSh = Nothing
MsgBox Err.Description, vbExclamation
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' ライン消去
Call Lines_Del
' アクセス権を破棄してオブジェクトの参照を開放
If Not mDIDevM Is Nothing Then
mDIDevM.Unacquire
End If
Set mDIDevM = Nothing
Set mDI = Nothing
Set mDX = Nothing
Set mSh = Nothing
End Sub
Private Sub ToggleButton1_Change()
Dim i As Long
With Me.ToggleButton1
If .Value Then
With Application
.Cursor = xlNorthwestArrow
.StatusBar = "" 'チラつくので消しておく
End With
.Caption = "Cross Cursol On"
' ライン描写
Call Lines_Add
Call LineMove
' アクセス権取得
If Not mDIDevM Is Nothing Then
mDIDevM.Acquire
End If
Else
Call Lines_Del
With Application
.Cursor = xlDefault
.StatusBar = False
End With
' アクセス権破棄
.Caption = "Cross Cursol Off"
On Error Resume Next
mDIDevM.Unacquire
' 待機(簡易ウェイト...なんかうまく開放されない時があるので2回試す)
For i = 1 To 500000: DoEvents: Next i
mDIDevM.Unacquire
On Error GoTo 0
Call SetActiveWindow(FindWindow("XLMAIN", vbNullString))
End If
End With
End Sub
Private Sub InitDirextInput()
Set mDX = New DxVBLibA.DirectX8
Set mDI = mDX.DirectInputCreate()
If mDI Is Nothing Then
Err.Raise 1000, , "DirectInput オブジェクト生成に失敗しました."
End If
Set mDIDevM = mDI.CreateDevice("guid_SysMouse")
If mDIDevM Is Nothing Then
Err.Raise 1000, , "DirectInputDevice オブジェクト生成に失敗しました."
Else
mDIDevM.SetCommonDataFormat DIFORMAT_MOUSE2
mDIDevM.SetCooperativeLevel mhWnd, DISCL_BACKGROUND Or DISCL_NONEXCLUSIVE
Dim diprop As DxVBLibA.DIPROPLONG
With diprop
.lHow = DIPH_DEVICE
.lObj = 0
.lData = 10
End With
mDIDevM.SetProperty "DIPROP_BUFFERSIZE", diprop
mhEventM = mDX.CreateEvent(Me)
mDIDevM.SetEventNotification mhEventM
End If
End Sub
' DirectX イベント
Private Sub DirectXEvent8_DXCallback(ByVal eventid As Long)
Dim X As Long
Dim lngX As Long
Dim lngY As Long
Select Case eventid
Case mhEventM ' マウスイベント
Dim devdata(MAX_BUFFERSIZE - 1) As DxVBLibA.DIDEVICEOBJECTDATA
Dim datacnt As Long
On Error Resume Next
datacnt = mDIDevM.GetDeviceData(devdata, DIGDD_DEFAULT)
If Err Then
datacnt = 0
mDIDevM.Acquire
End If
On Error GoTo 0
For X = 0 To datacnt - 1
With devdata(X)
Select Case .lOfs
Case DIMOFS_X, DIMOFS_Y ' X軸、Y軸の移動
Call LineMove
Case Else
End Select
End With
Next
Case Else
End Select
End Sub
Private Sub LineMove()
Dim sglL As Single
Dim sglT As Single
If Not mSh Is ActiveSheet And Me.ToggleButton1.Value Then
Call Lines_Add
Set mSh = ActiveSheet
Else
On Error Resume Next
Call GetCursorPos(MoP)
sglL = (MoP.X - ActiveWindow.PointsToScreenPixelsX _
(Range("A1").Top)) * 3 / 4
sglT = (MoP.Y - ActiveWindow.PointsToScreenPixelsY _
(Range("A1").Left)) * 3 / 4
mLine_V.Left = sglL
mLine_H.Top = sglT
End If
End Sub
Private Sub Lines_Add()
Dim sglW As Single, sglH As Single
On Error GoTo ERROR_HANDLER
Call Lines_Del
sglW = Range("IV1").Left + 500
sglH = Range("A65536").Top + 500
Set mLine_H = Nothing
Set mLine_V = Nothing
Set mLine_H = ActiveSheet.Shapes.AddLine(0#, 10#, sglW, 10#)
With mLine_H
.Name = "$CurLine_H$" & .Name
.Line.Weight = 1
.Line.Style = msoLineSingle
.Line.ForeColor.SchemeColor = 48
End With
Set mLine_V = ActiveSheet.Shapes.AddLine(10#, 0#, 10#, sglH)
With mLine_V
.Name = "$CurLine_V$" & .Name
.Line.Weight = 1
.Line.Style = msoLineSingle
.Line.ForeColor.SchemeColor = 48
End With
Exit Sub
ERROR_HANDLER:
MsgBox "ライン描写に失敗しました.", vbExclamation
End Sub
'----------------- 標準モジュール ---------------------------------
Option Explicit
' ユーザーにもラインを消せるように、標準モジュールにおく
Sub Lines_Del()
Dim Wb As Workbook
Dim Sh As Worksheet
Dim shpLine As Shape
On Error Resume Next
For Each Wb In Workbooks
For Each Sh In Wb.Worksheets
For Each shpLine In Sh.Shapes
If shpLine.Name Like "$CurLine_*" Then
shpLine.Delete
End If
Next shpLine
Next Sh
Next Wb
End Sub
No.2
- 回答日時:
すみません。
おすすめしないとはいえ、中途半端すぎました^ ^;とりあえずZoom=100ならこれで大丈夫なはず。
Sub Lin_Cursor()
Dim Tn As Single, Ln As Single
Application.Cursor = xlNorthwestArrow
Application.StatusBar = "Lin_Cursor On"
Do
DoEvents
GetCursorPos MoP
With MoP
Ln = (.x - ActiveWindow.PointsToScreenPixelsX _
(Range("A1").Left)) * 3 / 4
Tn = (.y - ActiveWindow.PointsToScreenPixelsY _
(Range("A1").Top)) * 3 / 4
End With
If Not Lflg Then Exit Do
With ActiveSheet.Lines("line_H")
.Top = Tn
.Left = Ln - 1500
.Width = 3000
End With
With ActiveSheet.Lines("line_v")
.Top = Tn - 1000
.Left = Ln
.Height = 2000
End With
Loop
Application.Cursor = xlDefault
Application.StatusBar = False
End Sub
また、最低限↓これは必要でした。
'■ThisWorkbookモジュール
Private Sub Workbook_Deactivate()
解除
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
解除
End Sub
No.1
- 回答日時:
こんにちは。
サンプルですが、触りだけ^ ^'■標準モジュールに
Option Explicit
Private Lflg As Boolean
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetCursorPos Lib _
"user32.dll" (lpPoint As POINTAPI) As Long
Private MoP As POINTAPI, GetX As Single, GetY As Single
Sub Lines_Add() 'LineShapeをつくる。初回のみ
With ActiveSheet
On Error Resume Next
.Lines("line_H").Delete
.Lines("line_V").Delete
On Error GoTo 0
With .Lines.Add(0, 0, 3000, 0)
.Name = "line_H"
With .ShapeRange.Line
.Weight = 1
.Style = msoLineSingle
.ForeColor.SchemeColor = 48
End With
End With
With .Lines.Add(0, 0, 0, 2000)
.Name = "line_V"
With .ShapeRange.Line
.Weight = 1
.Style = msoLineSingle
.ForeColor.SchemeColor = 48
End With
End With
End With
End Sub
Sub スタート()
Lflg = True
Lin_Cursor
End Sub
Sub 解除()'ボタンやショートカットキーやイベントに割り当てたり。
Lflg = False
End Sub
Sub Lin_Cursor() '本体。Constは環境によって調整必要。
Dim Tn As Single, Ln As Single
Const yi As Single = 103 'シート上のy座標の初期修正値。
Const xi As Single = 28 'シート上のx座標の初期修正値。
Const N As Single = 1.336 '係数のようなもの。
Application.Cursor = xlNorthwestArrow
Application.StatusBar = "Lin_Cursor On"
Do
DoEvents
With ActiveWindow.VisibleRange
GetCursorPos MoP
Tn = (MoP.y - yi) / N + .Top
Ln = (MoP.x - xi) / N + .Left
End With
With ActiveSheet.Lines("line_H")
.Top = Tn
.Left = Ln - 1500
.Width = 3000
End With
With ActiveSheet.Lines("line_v")
.Top = Tn - 1000
.Left = Ln
.Height = 2000
End With
Loop Until Not Lflg
Application.Cursor = xlDefault
Application.StatusBar = False
End Sub
ウィンドウのサイズや位置の変更によって、またツールバーの高さによっても位置がずれますので、
少し工夫が必要ですね。
DoLoopで常にマクロ実行しているわけですから、CPU負担も高いし、
入力時には解除しないといけないので基本的にはおすすめしません。
MauseMoveではなくて、Cell選択時の動作でよければWorksheet_SelectionChangeを使って、
A)条件付き書式と組み合わせる方法。
B)Lineシェイプを使う方法。
などがあります。特定のシートだけなら比較的簡単です。
参考URLのリンク先も辿ってみてください。
参考URL:http://park7.wakwak.com/~efc21/cgi-bin/wwwlng.cg …
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- その他(Microsoft Office) Excel2003,2007の作業です 2 2023/05/17 09:58
- Excel(エクセル) エクセルVBA 任意のセルの選択時、指定のセルの値を表示 1 2023/04/21 08:13
- Visual Basic(VBA) エクセルのマクロで対象ごとにシート分けしてその内容をセルに書き込みたい 9 2022/08/24 13:23
- Excel(エクセル) エクセルの祝日に色が反映しない 4 2022/05/18 09:58
- Excel(エクセル) 指定値をマクロで検索&シート移動 2 2022/04/27 23:29
- Excel(エクセル) エクセルで”入力シート”の文字書式の変更を”出力シート”で同じ文字書式で印刷したいです。VBA希望 4 2023/04/24 11:07
- Excel(エクセル) エクセルの条件付き書式で*を使いたい 4 2022/05/13 16:49
- Excel(エクセル) エクセルの関数について 5 2023/04/30 17:24
- Excel(エクセル) Excel2019 列と列(2列)の数値の重複を調べたい 1 2023/05/11 13:35
- Visual Basic(VBA) エクセルマクロでアニメを作る方法を教えてください。 1 2023/02/07 14:27
このQ&Aを見た人はこんなQ&Aも見ています
関連するカテゴリからQ&Aを探す
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
相手側の携帯が電源切れてる時...
-
1コールだけ鳴るけど切れる電話...
-
face book で女性の方からline ...
-
よく05(04)lineって見かけるん...
-
Windowsのバッチファイルで正規...
-
いきなりラインのトークに「新...
-
生産ラインの品質を表す直行率...
-
lineのワン切り、なぜ?
-
line でおはようございます、の...
-
既婚女性にラインを聞くことに...
-
ラインナップとラインアップは...
-
「一番上、真ん中、下」を示す英語
-
3ヶ月前に別れた彼とはカカオト...
-
LINEで好きな人が「笑」を全然つ...
-
質問です。 先日クラスの女子に...
-
妊娠したらどうする?聞くのは...
-
遠くにいる友達とLINE交換する...
-
タイトルの改行
-
相手が携帯を解約していたら、L...
-
2000年生まれなのですが 00line...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
相手側の携帯が電源切れてる時...
-
phpとpostgreの接続にエラー解...
-
1コールだけ鳴るけど切れる電話...
-
face book で女性の方からline ...
-
よく05(04)lineって見かけるん...
-
Windowsのバッチファイルで正規...
-
LINE追加で「該当するユーザー...
-
ラインナップとラインアップは...
-
生産ラインの品質を表す直行率...
-
いきなりラインのトークに「新...
-
ある男子から、ライン追加され...
-
「一番上、真ん中、下」を示す英語
-
遠くにいる友達とLINE交換する...
-
LINEで好きな人が「笑」を全然つ...
-
質問です。 先日クラスの女子に...
-
法線(normal line)はなぜそう...
-
python flask から fastapiへの...
-
lineのワン切り、なぜ?
-
私がlineのアイコンを変更する...
-
教えてください
おすすめ情報