投稿‎ > ‎

Excelに赤い枠を付けよう

posted Dec 28, 2014, 11:15 PM by Zhang Wenxu   [ updated May 22, 2015, 9:15 PM ]
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

 
Comments