cle_Click()
Command=ecCreateCircle
EndSub
PrivateSubDelete_Click()
'删除被选中的所有图元
AllSelRemove
'更新图片框中的内容
DrawMain.picDraw.Refresh
EndSub
PrivateSubExtent_Click()
DimminXAsDouble
DimminYAsDouble
DimmaxXAsDouble
DimmaxYAsDouble
DimrcAsrect
DimrcLBAsNewPosition
DimrcRTAsNewPosition
DimscalexAsDouble,scaleyAsDouble
CallGetClientRect(DrawMain.picDraw.hwnd,rc)
WithrcLB
.x=rc.Left*Screen.TwipsPerPixelX
.y=rc.Bottom*Screen.TwipsPerPixelY
EndWith
WithrcRT
.x=rc.Right*Screen.TwipsPerPixelX
.y=rc.Top*Screen.TwipsPerPixelY
EndWith
CallGetExtentBox(minX,minY,maxX,maxY)
'计算新坐标系与逻辑坐标的比例因子
scalex=Abs((rcRT.x-rcLB.x)/(maxX-minX))
scaley=Abs((rcRT.y-rcLB.y)/(maxY-minY))
scale1=min(scalex,scaley)
'重新设置视口大小
sLeft=minX
sTopic=maxY
Ifscalex
0Then
ForEachpLineInSelLines
SetpGElement=pLine
WithpGElement
.Draw(edmDelete)'清除原来位置上的图元
Call.ScaleTransform(scalex,scaley)
.Draw(edmSelect)
EndWith
WithpLine
lines.Remove(Str(.ID_Line))
Calllines.Add(.geLineWidth,.geLineStyle,.geColor,.ID_Line,.pLineBegin,.pLineEnd,Str(.ID_Line))
EndWith
Next
ForEachpPLineInSelPLines
SetpGElement=pPLine
WithpGElement
.Draw(edmDelete)
Call.ScaleTransform(scalex,scaley)
.Draw(edmSelect)
EndWith
WithpPLine
DimPLPoints(1To100,1To100)AsPosition
Fori=1To.intPLinePointNum
SetPLPoints(.ID_PLine,i)=.pPLPoints(.ID_PLine,i)
Nexti
polylines.Remove(Str(.ID_PLine))
Callpolylines.Add(.intPLinePointNum,PLPoints,.geLineWidth,.geLineStyle,.geColor,.ID_PLine,Str(.ID_PLine))
EndWith
Next
ForEachpCircleInSelCircles
SetpGElement=pCircle
WithpGElement
.Draw(edmDelete)
Call.ScaleTransform(scalex,scaley)
.Draw(edmSelect)
EndWith
WithpCircle
circles.Remove(Str(.ID_Circle))
Callcircles.Add(.geLineWidth,.geLineStyle,.geColor,.pCircleR,.pCenter,.ID_Circle,Str(.ID_Circle))
EndWith
Next
ForEachpArcInSelArcs
SetpGElement=pArc
WithpGElement
.Draw(edmDelete)
Call.ScaleTransform(scalex,scaley)
.Draw(edmSelect)
EndWith
WithpArc
arcs.Remove(Str(.ID_Arc))
Callarcs.Add(.geLineWidth,.geLineStyle,.geColor,.pCenter,.pBegin,.pEnd,.ID_Arc,Str(.ID_Arc))
EndWith
Next
EndIf
DrawMain.picDraw.DrawMode=6
EndSub
PrivateSubZoomOut_Click()
sLeft=sLeft*0.8
sRight=sRight*0.8
sTopic=sTopic*0.8
sBottom=sBottom*0.8
CallCoordinate
EndSub
PrivateSubGetExtentBox(minXAsDouble,minYAsDouble,maxXAsDouble,maxYAsDouble)
DimpLineAsNewCLine
DimpPLineAsNewCPolyLine
DimpCircleAsNewCCircle
DimpArcAsNewCArc
DimpTextAsNewCText
DimpGElementAsCGElement
DimsourceBoxAsNewBox
DimiAsInteger
'给矩形对角顶点的坐标赋初值
minX=0
minY=0
maxX=0
maxY=0
'按指定绘图模式重绘所有图元
ForEachpLineInlines
WithpLine
SetptLineBegin=.pLineBegin
SetptLineEnd=.pLineEnd
EndWith
SetpGElement=pLine
CallpGElement.GetBox(sourceBox)
WithsourceBox
minX=min(minX,.minX)
minY=min(minY,.minY)
maxX=max(maxX,.maxX)
maxY=max(maxY,.maxY)
EndWith
Next
ForEachpPLineInpolylines
WithpPLine
intPLPointNum=.intPLinePointNum
Fori=1TointPLPointNum
SetptPLPoints(.ID_PLine,i)=.pPLPoints(.ID_PLine,i)
Nexti
EndWith
SetpGElement=pPLine
CallpGElement.GetBox(sourceBox)
WithsourceBox
minX=min(minX,.minX)
minY=min(minY,.minY)
maxX=max(maxX,.maxX)
maxY=max(maxY,.maxY)
EndWith
Next
ForEachpCircleIncircles
WithpCircle
SetptCircleCenter=.pCenter
SetptCircleR=.pCircleR
EndWith
SetpGElement=pCircle
CallpGElement.GetBox(sourceBox)
WithsourceBox
minX=min(minX,.minX)
minY=min(minY,.minY)
maxX=max(maxX,.maxX)
maxY=max(maxY,.maxY)
EndWith
Next
ForEachpArcInarcs
WithpArc
SetptArcCenter=.pCenter
SetptArcBegin=.pBegin
SetptArcEnd=.pEnd
EndWith
SetpGElement=pArc
CallpGElement.GetBox(sourceBox)
WithsourceBox
minX=min(minX,.minX)
minY=min(minY,.minY)
maxX=max(maxX,.maxX)
maxY=max(maxY,.maxY)
EndWith
Next
ForEachpTextIntexts
SetpGElement=pText
CallpGElement.GetBox(sourceBox)
WithsourceBox
minX=min(minX,.minX)
minY=min(minY,.minY)
maxX=max(maxX,.maxX)
maxY=max(maxY,.maxY)
EndWith
Next
EndSub
上一篇:VB用VB开发交互式cad系统(论文和程序)
下一篇:法律专业开题报告范文