Changeset 688


Ignore:
Timestamp:
Mar 11, 2009, 4:56:32 PM (16 years ago)
Author:
イグトランス (egtra)
Message:

Circle命令語の描画開始・終了位置の算出をSin/Cosで行うように変更

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ab5.0/ablib/src/basic/prompt.sbp

    r685 r688  
    632632'Prompt graphic command functions
    633633
    634 Sub Circle(x As Long , y As Long, radius As Double, ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
    635     Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
    636 
    637     Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
     634Sub Circle(x As Double, y As Double, radius As Double, ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
     635    Dim hPen = CreatePen(PS_SOLID, 1, GetBasicColor(ColorCode))
    638636    Dim hBrush As HBRUSH
    639637    If bFill Then
     
    643641    End If
    644642
    645     Dim hDC = GetDC(_PromptSys_hWnd)
    646     Dim hOldPenDC = SelectObject(hDC, hPen)
    647     Dim hOldBrushDC = SelectObject(hDC, hBrush)
     643    Dim hdc = GetDC(_PromptSys_hWnd)
     644    Dim hOldPenDC = SelectObject(hdc, hPen)
     645    Dim hOldBrushDC = SelectObject(hdc, hBrush)
    648646    Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
    649647    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
    650648
    651     Dim radi2 As Long
    652     Dim iRadius As Long
    653     If Aspect<1 Then
    654         radi2 = (radius * Aspect) As Long
    655         iRadius = radius As Long
     649    Dim yRadius As Double
     650    Dim xRadius As Double
     651    If Aspect = 1 Then
     652        yRadius = radius
     653        xRadius = radius
     654    ElseIf Aspect < 1 Then
     655        yRadius = radius * Aspect
     656        xRadius = radius
    656657    Else
    657         radi2 = radius As Long
    658         iRadius = (radius / Aspect) As Long
    659     End If
    660 
    661     If StartPos=0 And EndPos=0 Then
    662         Ellipse(hDC,x-iRadius,y-radi2,x+iRadius,y+radi2)
    663         Ellipse(_PromptSys_hMemDC,x-iRadius,y-radi2,x+iRadius,y+radi2)
     658        yRadius = radius
     659        xRadius = radius / Aspect
     660    End If
     661
     662    Dim x1 = (x - xRadius) As Long
     663    Dim x2 = (x + xRadius) As Long
     664    Dim y1 = (y - yRadius) As Long
     665    Dim y2 = (y + yRadius) As Long
     666
     667    If StartPos = 0 And EndPos = 0 Then
     668        Ellipse(hdc, x1, y1, x2, y2)
     669        Ellipse(_PromptSys_hMemDC, x1, y1, x2, y2)
    664670    Else
    665         Dim sw As Boolean
    666         StartPos *= 100
    667         EndPos *= 100
    668 
    669         If StartPos<0 Or EndPos<0 Then
    670             sw = True
     671        Dim isPie As Boolean
     672        If StartPos < 0 Or EndPos < 0 Then
     673            isPie = True
    671674            StartPos = Math.Abs(StartPos)
    672675            EndPos = Math.Abs(EndPos)
    673676        Else
    674             sw = False
     677            isPie = False
    675678        End If
    676679
    677         If StartPos<=78.5 Then
    678             i1=78
    679             i2=Int(StartPos)
    680         ElseIf StartPos<=235.5 Then
    681             StartPos -= 78.5
    682             i1=78-Int(StartPos)
    683             i2=78
    684         ElseIf StartPos<=392.5 Then
    685             StartPos -= 235.5
    686             i1=-78
    687             i2=78-Int(StartPos)
    688         ElseIf StartPos<=549.5 Then
    689             StartPos -= 392.5
    690             i1=-78+Int(StartPos)
    691             i2=-78
    692         ElseIf StartPos<=628 Then
    693             StartPos -= 549.5
    694             i1=78
    695             i2=-78+Int(StartPos)
     680        Dim scaleRadial = (x + y) * 0.5
     681        Dim startX = (x + ActiveBasic.Math.Cos(StartPos) * scaleRadial) As Long
     682        Dim startY = (y - ActiveBasic.Math.Sin(StartPos) * scaleRadial) As Long
     683        Dim endX = (x + ActiveBasic.Math.Cos(EndPos) * scaleRadial) As Long
     684        Dim endY = (y - ActiveBasic.Math.Sin(EndPos) * scaleRadial) As Long
     685
     686        If isPie Then
     687            Pie(hdc, x1, y1, x2, y2, startX, startY, endX, endY)
     688            Pie(_PromptSys_hMemDC, x1, y1, x2, y2, startX, startY, endX, endY)
     689        Else
     690            Arc(hdc, x1, y1, x2, y2, startX, startY, endX, endY)
     691            Arc(_PromptSys_hMemDC, x1, y1, x2, y2, startX, startY, endX, endY)
    696692        End If
    697 
    698         If EndPos<=78.5 Then
    699             i3=78
    700             i4=Int(EndPos)
    701         ElseIf EndPos<=235.5 Then
    702             EndPos -= 78.5
    703             i3=78-Int(EndPos)
    704             i4=78
    705         ElseIf EndPos<=392.5 Then
    706             EndPos -= 235.5
    707             i3=-78
    708             i4=78-Int(EndPos)
    709         ElseIf EndPos<=549.5 Then
    710             EndPos -= 392.5
    711             i3=-78+Int(EndPos)
    712             i4=-78
    713         ElseIf EndPos<=628 Then
    714             EndPos -= 549.5
    715             i3=78
    716             i4=-78+Int(EndPos)
    717         End If
    718 
    719         If sw Then
    720             Pie(hDC,x-iRadius,y-radi2,x+iRadius,y+radi2, x+i1,y-i2,x+i3,y-i4)
    721             Pie(_PromptSys_hMemDC,x-iRadius,y-radi2,x+iRadius,y+radi2, x+i1,y-i2,x+i3,y-i4)
    722         Else
    723             Arc(hDC,x-iRadius,y-radi2,x+iRadius,y+radi2, x+i1,y-i2,x+i3,y-i4)
    724             Arc(_PromptSys_hMemDC,x-iRadius,y-radi2,x+iRadius,y+radi2, x+i1,y-i2,x+i3,y-i4)
    725         End If
    726     End If
    727 
    728     SelectObject(hDC, hOldPenDC)
    729     SelectObject(hDC, hOldBrushDC)
    730     ReleaseDC(_PromptSys_hWnd, hDC)
     693    End If
     694
     695    SelectObject(hdc, hOldPenDC)
     696    SelectObject(hdc, hOldBrushDC)
     697    ReleaseDC(_PromptSys_hWnd, hdc)
    731698    SelectObject(_PromptSys_hMemDC, hOldPen)
    732699    SelectObject(_PromptSys_hMemDC, hOldBrush)
     
    912879    '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
    913880    'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2]
    914     ActiveBasic.Prompt.Detail.Circle(x As Long, y As Long, radius, ColorCode, StartPos, EndPos, Aspect, bFill, BrushColor)
     881    ActiveBasic.Prompt.Detail.Circle(x, y, radius, ColorCode, StartPos, EndPos, Aspect, bFill, BrushColor)
    915882End Macro
    916883
Note: See TracChangeset for help on using the changeset viewer.