plotgra.bas

用于三次采油技术的经济评价

   ReDim fx(100), xtic1(100), xtic2(100)
   Static ltg  As String
   ReDim tx(100)
   
   xs = object1.ScaleWidth * 0.15 / 2 + object1.TextWidth("100") * 0.8
   ys = object1.ScaleHeight * 0.25 / 2 - object1.TextHeight("100") * 0.8
   'xe = object1.ScaleWidth * (1 - .15 / 2) + object1.TextWidth("100") * .8
   ye = object1.ScaleHeight * (1 - 0.25 / 2) - object1.TextHeight("100") * 0.8

   ltg = "y"
   ltype = 2
    
   Open "zfdata.mid" For Input As #4
   Input #4, nn
   nn = 6
   For i = 1 To nn
    Input #4, tx(i), fx(i)
   Next i
   Close #4

   NY = 8
   xcq = object1.ScaleWidth / 40     '200
   ycq = object1.ScaleHeight / 40    '200
   yd = (ye - ys) / NY   '200#
   'xx = (object1.ScaleWidth * .8 - xcq * (nn + 1) * 1.05) / nn: xd = xx / 3
   xx = object1.ScaleWidth * 0.8 / ((nn + 1) / 3 + nn): xd = xx / 3
   
   'xd = 400#: xx = 1000#
   zfcolor = 12: yymax = ye + ycq + yd + 100

   For i = 1 To nn
    xtic1(i) = xs + xd + (i - 1) * (xx + xd)
    xtic2(i) = xs + i * (xx + xd)
   Next i
   fx(nn + 1) = 0#
   Call maxmin(fx(), nn + 1, fxmax, fxmin)
   Call bhx(fx(), ys, ye, nn + 1)
   If UCase$(ltg) = "Y" Then
    object1.Line (xs, yymax - ys)-(xtic2(nn) + xd, yymax - ys), QBColor(0)
    object1.Line -(xtic2(nn) + xd + xcq, yymax - (ys + ycq)), QBColor(0)
    object1.Line -(xtic2(nn) + xd + xcq, yymax - (ye + yd + ycq)), QBColor(8)
    object1.Line -(xs + xcq, yymax - (ye + yd + ycq)), QBColor(8)
    object1.Line -(xs + xcq, yymax - (ys + ycq)), QBColor(8)
    object1.Line -(xs, yymax - ys), QBColor(8)
    object1.Line -(xs, yymax - (ye + yd)), QBColor(0)
    object1.Line -(xs + xcq, yymax - (ye + yd + ycq)), QBColor(8)
   Else
    object1.Line (xs, yymax - ys)-(xtic2(nn) + xd, yymax - ys)
    object1.Line -(xtic2(nn) + xd, yymax - ys)
    object1.Line -(xtic2(nn) + xd, yymax - (ye + yd))
    object1.Line -(xs, yymax - (ye + yd))
    object1.Line -(xs, yymax - ys)
   End If
   dyt = fxmax / NY
   dyy = (ye - ys) / NY
   For i = 1 To NY + 1
    YT = (i - 1) * dyt
    yy = ys + (i - 1) * dyy
    If i > 1 Then
     If UCase$(ltg) = "Y" Then
      yyycq = yy + ycq
      object1.PSet (xs + xcq, yymax - yyycq), QBColor(0)
      xt2 = xtic1(1)
      If yy < fx(1) And yy > fx(1) - ycq Then
       xt2 = xt2 + (yyycq - fx(1)) * xcq / ycq
      End If
      object1.Line -(xt2, yymax - yyycq), QBColor(0)
      For k = 1 To nn
       If yy < fx(k) Then
        object1.PSet (xtic2(k) + xcq, yymax - yyycq), QBColor(0)
       Else
        object1.Line -(xtic2(k) + xcq, yymax - yyycq), QBColor(0)
       End If
       xt2 = xtic2(k) + xd
       If yy < fx(k + 1) And yy > fx(k + 1) - ycq Then
        xt2 = xt2 + (yyycq - fx(k + 1)) * xcq / ycq
       End If
       object1.Line -(xt2, yymax - yyycq), QBColor(0)
      Next k
      object1.Line -(xtic2(nn) + xd + xcq, yymax - yyycq), QBColor(0)
      object1.Line (xs + xcq, yymax - yyycq)-(xs, yymax - yy), QBColor(0)
     Else
      object1.Line (xs, yymax - yy)-(xtic1(1), yymax - yy)
      For k = 1 To nn
       If yy < fx(k) Then
        object1.PSet (xtic2(k), yymax - yy)
       Else
        object1.Line -(xtic2(k), yymax - yy)
       End If
       object1.Line -(xtic2(k) + xd, yymax - yy)
      Next k
      object1.Line -(xtic2(nn) + xd, yymax - yy)
     End If
    End If
    object1.Line (xs, yymax - yy)-(xs + 100, yymax - yy), QBColor(0)
    If Abs(YT) > 0.00001 Then
     Bit = Int(Log(Abs(YT)) / Log(10))
     YT = Int(YT / 10 ^ Bit * 100) / 100 * 10 ^ Bit
    End If
    printtext$ = Str$(YT)
    object1.CurrentX = xs - object1.TextWidth(printtext$) * 1.1
    object1.CurrentY = yymax - (yy + object1.TextHeight(printtext$) * 0.5)
    object1.Print Str$(YT)
   Next i
   '绘制柱体
   For i = 1 To nn
    Call pat(xtic1(i), xtic2(i), ys, fx(i), ltype, yymax, object1)
    If UCase$(ltg) = "Y" Then
     object1.Line (xtic1(i), yymax - fx(i))-(xtic1(i) + xcq, yymax - (fx(i) + ycq)), QBColor(zfcolor)
     object1.Line -(xtic2(i) + xcq, yymax - (fx(i) + ycq)), QBColor(zfcolor)
     object1.Line -(xtic2(i), yymax - fx(i)), QBColor(zfcolor)
     object1.Line (xtic2(i) + xcq, yymax - (fx(i) + ycq))-(xtic2(i) + xcq, yymax - (ys + ycq)), QBColor(zfcolor)
     object1.Line -(xtic2(i), yymax - ys), QBColor(zfcolor)
    End If
    object1.Line (xtic1(i), yymax - ys)-(xtic1(i), yymax - fx(i)), QBColor(zfcolor)
    object1.Line -(xtic2(i), yymax - fx(i)), QBColor(zfcolor)
    object1.Line -(xtic2(i), yymax - ys), QBColor(zfcolor)
   Next i
   '绘制Y方向第一条内线
   If UCase$(ltg) = "Y" Then
    object1.PSet (xs + xcq, yymax - (ys + ycq)), QBColor(8)
    For i = 1 To nn
     xt1 = xtic1(i)
     If fx(i) < ys + ycq Then xt1 = (ys + ycq - fx(i)) * xcq / ycq + xtic1(i)
     object1.Line -(xt1, yymax - (ys + ycq)), QBColor(8)
     object1.PSet (xtic2(i) + xcq, yymax - (ys + ycq)), QBColor(8)
    Next i
    object1.Line -(xtic2(nn) + xd + xcq, yymax - (ys + ycq)), QBColor(8)
   End If
   For i = 1 To nn
    object1.CurrentX = xtic1(i) + xx / 2# - object1.TextWidth(tx(i))
    object1.CurrentY = yymax - (ys - object1.TextHeight(tx(i)) * 0.5)
    object1.Print tx(i)
   Next i
End Sub

Sub post(x0, y0, hl, corp, ik, object1 As Object)
    Rem 标写图形符号
    Rem hl ---- 以坐标点为中心的图符高度;
    Rem ik ---- 控制绘制图符的类型:
    Rem  -1:无
    Rem  0:空心园;     1:实心园;     2:空心矩形;    3:实心矩形;   4:十字符号;   5:米形符号;
    Rem  6:空心三角形; 7:实心三角形; 8:空心四角星;   9:实心四角星; 10:空心五角星;11:实心五角星;
    Rem  12:空心六角星;13:实心六角星;14:空心七角星; 15:实心七角星;16:空心八角星;17:实心八角星.
    Static xxq(), yyq() As Single
    ReDim xxq(200), yyq(200)
    h = 0.5 * hl
    If ik < 0 Or ik > 17 Then Exit Sub
    Select Case ik
     Case 0:
      object1.FillStyle = 0
      object1.FillColor = objBackColor
      object1.Circle (x0, y0), h, corp
      object1.FillStyle = 1
     Case 1:
      object1.FillStyle = 0
      object1.FillColor = corp
      object1.Circle (x0, y0), h, corp
      object1.FillStyle = 1
     Case 2:
      object1.FillStyle = 0
      object1.FillColor = objBackColor
      object1.Line (x0 - h, y0 - h)-(x0 + h, y0 + h), corp, B
      object1.FillStyle = 1
     Case 3:
      object1.Line (x0 - h, y0 - h)-(x0 + h, y0 + h), corp, BF
     Case 4, 5:
      object1.Line (x0 - h, y0)-(x0 + h, y0), corp
      object1.Line (x0, y0 - h)-(x0, y0 + h), corp
      If ik = 5 Then
       object1.Line (x0 + 0.707 * h, y0 - 0.707 * h)-(x0 - 0.707 * h, y0 + 0.707 * h), corp
       object1.Line (x0 - 0.707 * h, y0 - 0.707 * h)-(x0 + 0.707 * h, y0 + 0.707 * h), corp
      End If
     Case 6, 7:
      aj = 210# / 180# * 3.1416: aj1 = 330# / 180# * 3.1416
      object1.Line (x0, y0 + h)-(x0 + h * Cos(aj), y0 + h * Sin(aj)), corp
      object1.Line -(x0 + h * Cos(aj1), y0 + h * Sin(aj1)), corp
      object1.Line -(x0, y0 + h), corp
      If ik = 7 Then
       If h > 2 Then
        For ah = h To 2 Step -2
         object1.Line (x0, y0 + ah)-(x0 + ah * Cos(aj), y0 + ah * Sin(aj)), corp
         object1.Line -(x0 + ah * Cos(aj1), y0 + ah * Sin(aj1)), corp
         object1.Line -(x0, y0 + ah), corp
        Next ah
       End If
      End If
     Case Is >= 8
      jiaos = Int((ik + 0.5) / 2#)
      sc = 0.4
      djiao = 2# * 3.1416 / jiaos
      astart = 0.5 * 3.1416
      aend = 2.5 * 3.1416 + 0.1
      n = 0
      For ai = astart To aend Step djiao
       n = n + 1
       xxq(2 * n - 1) = x0 + h * Cos(ai): yyq(2 * n - 1) = y0 + h * Sin(ai)
       xxq(2 * n) = x0 + sc * h * Cos(ai + 0.5 * djiao): yyq(2 * n) = y0 + sc * h * Sin(ai + 0.5 * djiao)
      Next ai
      object1.PSet (xxq(1), yyq(1)), corp
      For i = 2 To 2 * n
       object1.Line -(xxq(i), yyq(i)), corp
      Next i
      If ik Mod 2 <> 0 Then
       If h > 2 Then
        For ah = h To 2 Step -2
         n = 0
         For ai = astart To aend Step djiao
          n = n + 1
          xxq(2 * n - 1) = x0 + ah * Cos(ai): yyq(2 * n - 1) = y0 + ah * Sin(ai)
          xxq(2 * n) = x0 + sc * ah * Cos(ai + 0.5 * djiao): yyq(2 * n) = y0 + sc * ah * Sin(ai + 0.5 * djiao)
         Next ai
         object1.PSet (xxq(1), yyq(1)), corp
         For i = 2 To 2 * n
          object1.Line -(xxq(i), yyq(i)), corp
         Next i
        Next ah
       End If
      End If
    End Select
    Erase xxq, yyq
End Sub

Sub TP(F1, F2, FB, PP)
  For i = 0 To Abs(F1) * 2 / FB + 0.5
   If Abs(F2) < i * FB / 2 Then PP = Sgn(F2) * (i - 1) * FB / 2: Exit Sub
  Next i
  PP = -9999
End Sub

Sub trigle1(x1, y1, x2, y2, cor1, cor2, object1 As Object)
   For i = y1 To y2
    object1.Line (x1 + 1, i)-(x2, y2), cor2
   Next
   object1.Line (x1 + 1, y1)-(x2, y2), cor1
End Sub

Sub trigle2(x1, y1, x2, y2, cor1, cor2, object1 As Object)
   For i = x1 To x2
    object1.Line (i, y1 + 2)-(x2, y2), cor2
   Next
   object1.Line (x1, y1 + 2)-(x2, y2), cor1
End Sub


Public Sub init_data()
   Lcolor(1) = &HFF&: Lcolor(2) = &HFF0000: Lcolor(3) = &HC000&
   Lcolor(4) = &H800080: Lcolor(5) = &H808000: Lcolor(6) = &HC0&
   Lcolor(7) = &H8080&: Lcolor(8) = &H800000
   For i = 1 To grnum_max
    gr_type(i) = 1: Pstyle(i) = i - 1
    Lstyle(i) = 0: Lwidth(i) = 1
    Pwidth(i) = 40: Pcolor(i) = Lcolor(i)
    grnote_visible(i) = -1: grnote_LR(i) = -1
   Next i
   
   px1 = 0#: py1 = 0#: px2 = 0#: py2 = 0#
   xaxis_type = 1: xaxis_visible = -1
   xaxis_min = 0#: xaxis_max = 0#: xaxis_interval = 0#: twoyaxis_interval = 0#
   TRborder_visible = -1
   title_fontsize = 14: axis_fontsize = 6.5: axisname_fontsize = 9: grnote_fontsize = 8
   
   For i = 1 To yaxis_num 'y轴数量
    yaxis_type(i) = 1: yaxis_min(i) = 0#
    yaxis_max(i) = 0#: yaxis_interval(i) = 0#
   Next i
End Sub