画误差椭圆.frm

一个附和导线的严密计算平差程序

VERSION 5.00
Begin VB.Form frmHuaTuoYuan 
   BackColor       =   &H8000000A&
   Caption         =   "绘制误差椭圆"
   ClientHeight    =   7920
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   11880
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   142
   ScaleMode       =   0  'User
   ScaleWidth      =   210
   Visible         =   0   'False
   Begin VB.CommandButton CmdTuoYuanSave 
      Caption         =   "椭圆保存"
      Enabled         =   0   'False
      Height          =   375
      Left            =   5640
      TabIndex        =   5
      Top             =   3120
      Width           =   1095
   End
   Begin VB.CommandButton CmdBack 
      Caption         =   "返回"
      Height          =   375
      Left            =   5640
      TabIndex        =   3
      Top             =   3840
      Width           =   1095
   End
   Begin VB.CommandButton CmdHuiTu 
      Caption         =   "绘图"
      Height          =   375
      Left            =   5640
      TabIndex        =   2
      Top             =   2400
      Width           =   1095
   End
   Begin VB.ComboBox CboTuoyuanBili 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   360
      Left            =   5640
      TabIndex        =   1
      Top             =   1440
      Width           =   1215
   End
   Begin VB.PictureBox PicHuaTuoYuan 
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000001&
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   12
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   4575
      Left            =   120
      ScaleHeight     =   79.64
      ScaleMode       =   0  'User
      ScaleWidth      =   90.223
      TabIndex        =   0
      Top             =   120
      Width           =   5175
   End
   Begin VB.Label LblTuoyuanBili 
      Caption         =   "椭圆比例尺"
      Height          =   255
      Left            =   5640
      TabIndex        =   4
      Top             =   1080
      Width           =   1095
   End
End
Attribute VB_Name = "frmHuaTuoYuan"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub CmdBack_Click()
  frmHuaTuoYuan.Visible = False
  Unload Me
End Sub

Private Sub CmdHuiTu_Click()
  Dim nx As Single
  PicHuaTuoYuan.Cls
  PicHuaTuoYuan.Scale (-Int(PicHuaTuoYuan.Width * 0.1), Int(PicHuaTuoYuan.Height - PicHuaTuoYuan.Width * 0.1))-(Int(PicHuaTuoYuan.Width * 0.9), -Int(PicHuaTuoYuan.Width * 0.1))
                  '定义图片框范围
  FillStyle = 7
  DrawWidth = 10
 ' Debug.Print Int(PicHuaTuoYuan.Width * 0.1)
  PicHuaTuoYuan.Line (-16, 0)-(160, 0), QBColor(4)
  PicHuaTuoYuan.Line (158, 1)-(160, 0), QBColor(4)
  With PicHuaTuoYuan
       .CurrentX = 152
       .CurrentY = -1
  End With
  PicHuaTuoYuan.Print "Y(mm)"
  PicHuaTuoYuan.Line (158, -1)-(160, 0), QBColor(4)
  With PicHuaTuoYuan
      .CurrentX = -3
      .CurrentY = -1
  End With
  PicHuaTuoYuan.Print "O"
  PicHuaTuoYuan.Line (0, -16)-(0, 120), QBColor(4)
  PicHuaTuoYuan.Line (-1, 118)-(0, 120), QBColor(4)
  PicHuaTuoYuan.Line (1, 118)-(0, 120), QBColor(4)
  With PicHuaTuoYuan
       .CurrentX = 2
       .CurrentY = 120
  End With
  PicHuaTuoYuan.Print "X(mm)"
  Call QiuTYdianXY(PicHuaTuoYuan.Width, PicHuaTuoYuan.Height)
  For nx = 1 To IntCount                 '画点，标点号和画点的椭圆
   With ZBP(nx)
     PicHuaTuoYuan.Circle (.x, .y), 0.5, QBColor(11)
     PicHuaTuoYuan.Print InputDat(nx).PiontName
    If (nx < IntCount) And (nx > 1) Then
     Call HuaDiantuoyuan(.x, .y, ZBJG(nx).E, ZBJG(nx).F, ZBJG(nx).Q, 1)
    End If
   End With
  Next nx
  Call Huaxian              '画两点间的连线
  
  For nx = 1 To IntCount - 1               '画两点的中点和画两点间的椭圆
     PicHuaTuoYuan.Circle ((ZBP(nx).x + ZBP(nx + 1).x) / 2, (ZBP(nx).y + ZBP(nx + 1).y) / 2), 0.5, QBColor(10)
     
     Call HuaDiantuoyuan((ZBP(nx).x + ZBP(nx + 1).x) / 2, (ZBP(nx).y + ZBP(nx + 1).y) / 2, Wzdty(nx).E, Wzdty(nx).F, Wzdty(nx).Q, 14)
  Next nx
  CmdTuoYuanSave.Enabled = True
End Sub

Private Sub CmdTuoYuanSave_Click()
   Dim str As Single
  j = InStr(StrFilename, ".")
  strOutputFileName = Left$(StrFilename, j) + "bmp"
  
   SavePicture PicHuaTuoYuan.Image, strOutputFileName
   str = MsgBox("椭圆图形已成功保存,是否退出", vbQuestion + vbYesNo, "退出")
   If str = vbYes Then
     frmHuaTuoYuan.Visible = fale
   End If
End Sub

Private Sub Form_Load()
   CboTuoyuanBili.Text = "1:1"
   CboTuoyuanBili.AddItem "3:1"
   CboTuoyuanBili.AddItem "2:1"
   CboTuoyuanBili.AddItem "1:1"
   CboTuoyuanBili.AddItem "1:2"
   CboTuoyuanBili.AddItem "1:3"
   CboTuoyuanBili.AddItem "1:4"
   CboTuoyuanBili.AddItem "1:5"
   CboTuoyuanBili.AddItem "1:6"
End Sub

Private Sub Form_Resize()
  Dim s As String
  With PicHuaTuoYuan
    .Left = 1
    .Top = 1
   ' Debug.Print Int(Me.ScaleHeight)
    'Debug.Print Int(Me.ScaleWidth)
    If Me.ScaleWidth >= 30 Then     '防止最小化出错
    .Width = Me.ScaleWidth - 30
    .Height = Me.ScaleHeight - 2
    End If
  End With
  With CboTuoyuanBili
     .Top = 10
     .Left = PicHuaTuoYuan.Width + 6
  End With
  With CmdHuiTu
     .Top = 25
     .Left = PicHuaTuoYuan.Width + 6
  End With
  With CmdBack
     .Top = 45
     .Left = PicHuaTuoYuan.Width + 6
  End With
  With LblTuoyuanBili
     .Top = 5
     .Left = PicHuaTuoYuan.Width + 7
  End With
  With CmdTuoYuanSave
     .Top = 35
     .Left = PicHuaTuoYuan.Width + 6
  End With
End Sub