Хочу RoundRect, уважающую пользовательскую систему координат

[tyomitch]

Иногда бывает удобно задать для PictureBoc/UserControl хитрую нестандартную систему координат, и работать в ней. В таком случае API RoundRect неприменима непосредственно.

Решил написать замену на чистом VB:

Код: Выделить всё

Sub RoundRect(ByVal ctx As Object, ByVal Left As Single, ByVal Top As Single, ByVal Right As Single, ByVal Bottom As Single, ByVal RadiusX As Single, ByVal RadiusY As Single)
Const pi = 3.14159265358979
'учесть баг в VB: аспект не масштабируется
Dim Aspect As Single, Radius As Single
    Radius = RadiusY * ctx.ScaleY(1, vbUser, vbPixels) / ctx.ScaleX(1, vbUser, vbPixels)
    Aspect = Abs(Radius) / RadiusX

If ctx.FillStyle = vbFSSolid Then
    Radius = Abs(Radius)
    ctx.Circle (Left + RadiusX, Top + RadiusY), Radius, , , , Aspect
    ctx.Circle (Right - RadiusX, Top + RadiusY), Radius, , , , Aspect
    ctx.Circle (Left + RadiusX, Bottom - RadiusY), Radius, , , , Aspect
    ctx.Circle (Right - RadiusX, Bottom - RadiusY), Radius, , , , Aspect
    ctx.Line (Left + RadiusX, Top)-(Right - RadiusX, Bottom), , B
    ctx.Line (Left, Top + RadiusY)-(Right, Bottom - RadiusY), , B
Else
    If Radius < 0 Then
        Radius = -Radius
        ctx.Circle (Left + RadiusX, Bottom - RadiusY), Radius, , pi * 0.5, pi, Aspect
        ctx.Circle (Right - RadiusX, Bottom - RadiusY), Radius, , 0, pi * 0.5, Aspect
        ctx.Circle (Left + RadiusX, Top + RadiusY), Radius, , pi, pi * 1.5, Aspect
        ctx.Circle (Right - RadiusX, Top + RadiusY), Radius, , pi * 1.5, 0, Aspect
    Else
        ctx.Circle (Left + RadiusX, Top + RadiusY), Radius, , pi * 0.5, pi, Aspect
        ctx.Circle (Right - RadiusX, Top + RadiusY), Radius, , 0, pi * 0.5, Aspect
        ctx.Circle (Left + RadiusX, Bottom - RadiusY), Radius, , pi, pi * 1.5, Aspect
        ctx.Circle (Right - RadiusX, Bottom - RadiusY), Radius, , pi * 1.5, 0, Aspect
    End If
    ctx.Line (Left + RadiusX, Top)-(Right - RadiusX, Top)
    ctx.Line (Left + RadiusX, Bottom)-(Right - RadiusX, Bottom)
    ctx.Line (Left, Top + RadiusY)-(Left, Bottom - RadiusY), , B
    ctx.Line (Right, Top + RadiusY)-(Right, Bottom - RadiusY), , B
End If
End Sub


Иногда (в частности, при "квадратных" и "вытянутых по горизонтали" пикселах) этот код работает. Что дописать, чтобы работал всегда?

[GSerg]

Код: Выделить всё

Option Explicit

Private Declare Function SetMapMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function SetWindowExtEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, ByRef lpSize As Any) As Long
Private Declare Function SetViewportExtEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, ByRef lpSize As Any) As Long
Private Declare Function RoundRect Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

Private Const MM_ANISOTROPIC As Long = 8


Private Sub Form_Load()
  Me.AutoRedraw = False
  Me.Width = Me.ScaleX(640, vbPixels, vbTwips)
  Me.Height = Me.ScaleY(480, vbPixels, vbTwips)
End Sub

Private Sub Command1_Click()
  Const X_UNITS_COUNT As Long = 5
  Const Y_UNITS_COUNT As Long = 5
 
  SetMapMode Me.hdc, MM_ANISOTROPIC
  SetWindowExtEx Me.hdc, X_UNITS_COUNT, Y_UNITS_COUNT, ByVal 0&
  SetViewportExtEx Me.hdc, Me.ScaleX(Me.Width, vbTwips, vbPixels), Me.ScaleY(Me.Height, vbTwips, vbPixels), ByVal 0&
 
  RoundRect Me.hdc, 1, 1, 4, 4, 1, 1
End Sub