Excelでエビデンスを検証するとき、またはアウトシェープのコメントを付けたいときに、結構手間が掛かる。 下記のマクロを使えば、カーソルの位置に、赤い枠が作成し、背景、文字色も設定するされる。 Public Const DPI As Double = 96# Public Const PPI As Double = 72# Public Const width As Long = 100 Public Const height As Long = 20 Public Const ROW_HEADER_WIDTH = 28 Public Const COLUMN_HEADER_HEIGHT = 14 Public Type POINTAPI x As Long y As Long End Type '64bitの場合は、PtrSafeをFunctionの前に追加する Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Public Sub drawRedBox() Dim shp As Shape Dim topLeftPixel As POINTAPI Dim topLeftPoint As POINTAPI Dim cursorPixel As POINTAPI Dim cursorPoint As POINTAPI Dim shpRightBottomPixel As POINTAPI GetCursorPos cursorPixel cursorPoint = pixel2Point(cursorPixel) Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, cursorPoint.x, cursorPoint.y, width, height) shp.Select shp.Fill.Visible = msoFalse With shp.Line .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 End With With shp.TextFrame2.TextRange.Font.Fill .Visible = msoTrue .ForeColor.RGB = RGB(255, 0, 0) .Transparency = 0 .Solid End With shpRightBottomPixel.x = cursorPixel.x + shp.width * DPI / PPI * (ActiveWindow.Zoom / 100) shpRightBottomPixel.y = cursorPixel.y + shp.height * DPI / PPI * (ActiveWindow.Zoom / 100) SetCursorPos shpRightBottomPixel.x, shpRightBottomPixel.y End Sub Public Function pixel2Point(pixel As POINTAPI) As POINTAPI Dim topLeftPoint As POINTAPI Dim topLeftPixel As POINTAPI Dim shp As Shape Dim diffPoint As POINTAPI Dim diffPixel As POINTAPI Dim scrollPoint As POINTAPI Dim cursorPixel As POINTAPI Dim cursorPoint As POINTAPI topLeftPixel.x = ActiveWindow.PointsToScreenPixelsX(0) topLeftPixel.y = ActiveWindow.PointsToScreenPixelsY(0) diffPixel.x = pixel.x - topLeftPixel.x diffPixel.y = pixel.y - topLeftPixel.y cursorPoint.x = diffPixel.x * PPI / DPI / (ActiveWindow.Zoom / 100) cursorPoint.y = diffPixel.y * PPI / DPI / (ActiveWindow.Zoom / 100) If ActiveWindow.SplitColumn > 0 Then cursorPoint.x = cursorPoint.x - Columns("A:" & colName(ActiveWindow.SplitColumn)).width - ROW_HEADER_WIDTH End If If ActiveWindow.SplitRow > 0 Then cursorPoint.y = cursorPoint.y - Rows("1:" & ActiveWindow.SplitRow).height - COLUMN_HEADER_HEIGHT End If pixel2Point = cursorPoint End Function |
投稿 >