form2.frm

一个勘察用的小软件,和华宁配套用. 一个勘察用的小软件,和华宁配套用.

Next i
With Pic
.Top = 200
.Height = Frame1.Height - 250
.Width = Frame1.Width - 60
.Left = 30
.AutoRedraw = True
End With
With Picture1
.Top = 0
.Height = 20000
.Width = Pic.Width - VScroll1.Width
.Left = 0
.AutoRedraw = True
End With
With VScroll1
.Height = Pic.Height
.Left = Picture1.Width
.Top = 0
End With
Combo1.ListIndex = 0
On Error Resume Next
End Sub
Private Sub command1_Click()
s = dk120(工程目录.Text, dcsj文件, Grid1, 钻孔号t.Text)
If s = 0 Then
MsgBox ("请选择正确目录")
Exit Sub
End If
Select Case Combo1.ListIndex
Case 0
qd = n120cd(工程目录.Text, n120文件, Sheet1, zd)
zdh = (Int(zd / 10) + 1) * 1000 + 1000
zdh = -zdh
''——————————————cd初始化作图空间————————————————————————————''
        Picture1.Cls
        'Scale方法设定用户坐标系，坐标原点在Picture1中心
        Picture1.ScaleMode = 6
        Picture1.Scale (0, 0)-(6280, -30000)
        '设置绘线宽度
        Picture1.DrawWidth = 1
        Picture1.Line (500, -1000)-(500, zdh)
        Picture1.Line (500, zdh)-(6000, zdh)
        Picture1.Line (500, -1000)-(6000, -1000)
        
        Picture1.Line (900, -1000)-(900, zdh), QBColor(1)
        Picture1.CurrentX = 750
        Picture1.Print 2
        Picture1.CurrentX = 750
        Picture1.CurrentY = -700
        Picture1.Print 2
        Picture1.Line (1300, -1000)-(1300, zdh), QBColor(1)
        Picture1.CurrentX = 1150
        Picture1.Print 4
        Picture1.CurrentX = 1150
        Picture1.CurrentY = -700
        Picture1.Print 4
        Picture1.Line (1900, -1000)-(1900, zdh), QBColor(1)
        Picture1.CurrentX = 1750
        Picture1.Print 7
        Picture1.CurrentX = 1750
        Picture1.CurrentY = -700
        Picture1.Print 7
        Picture1.Line (2500, -1000)-(2500, zdh), QBColor(1)
        Picture1.CurrentX = 2350
        Picture1.Print 10
        Picture1.CurrentX = 2350
        Picture1.CurrentY = -700
        Picture1.Print 10
        
        j = 0
        For i = -1000 To zdh + 1000 Step -1000
        Picture1.Line (400, i)-(500, i)
        Picture1.CurrentX = 50
        Picture1.CurrentY = i + 100
        Picture1.Print CStr((qd + j * 10) / 10)
        j = j + 1
    Next i
''——————————————cd初始化作图空间————————————————————————————''
Case 1
qd = n120gb(工程目录.Text, n120文件, Sheet1, zd)
zdh = (Int(zd / 10) + 1) * 1000 + 1000
zdh = -zdh
''——————————————gb初始化作图空间————————————————————————————''
        Picture1.Cls
        'Scale方法设定用户坐标系，坐标原点在Picture1中心
        Picture1.ScaleMode = 6
        Picture1.Scale (0, 0)-(6280, -30000)
        '设置绘线宽度
        Picture1.DrawWidth = 1
        Picture1.Line (500, -1000)-(500, zdh)
        Picture1.Line (500, zdh)-(6000, zdh)
        Picture1.Line (500, -1000)-(6000, -1000)
        
        Picture1.Line (700, -1000)-(700, zdh), QBColor(1)
        Picture1.CurrentX = 550
        Picture1.Print 1
        Picture1.CurrentX = 550
        Picture1.CurrentY = -700
        Picture1.Print 1
        Picture1.Line (1100, -1000)-(1100, zdh), QBColor(1)
        Picture1.CurrentX = 950
        Picture1.Print 3
        Picture1.CurrentX = 950
        Picture1.CurrentY = -700
        Picture1.Print 3
        Picture1.Line (1700, -1000)-(1700, zdh), QBColor(1)
        Picture1.CurrentX = 1550
        Picture1.Print 6
        Picture1.CurrentX = 1550
        Picture1.CurrentY = -700
        Picture1.Print 6
        Picture1.Line (2700, -1000)-(2700, zdh), QBColor(1)
        Picture1.CurrentX = 2550
        Picture1.Print 11
        Picture1.CurrentX = 2550
        Picture1.CurrentY = -700
        Picture1.Print 11
        Picture1.Line (3300, -1000)-(3300, zdh), QBColor(1)
        Picture1.CurrentX = 3150
        Picture1.Print 14
        Picture1.CurrentX = 3150
        Picture1.CurrentY = -700
        Picture1.Print 14
        
        j = 0
        For i = -1000 To zdh + 1000 Step -1000
        Picture1.Line (400, i)-(500, i)
        Picture1.CurrentX = 50
        Picture1.CurrentY = i + 100
        Picture1.Print CStr((qd + j * 10) / 10)
        j = j + 1
    Next i
''——————————————gb初始化作图空间————————————————————————————''
End Select


绘图 Sheet1, Picture1
End Sub



Private Sub Form_Resize()
With Pic
.Top = 200
.Height = Frame1.Height - 250
.Width = Frame1.Width - 60
.Left = 30
.AutoRedraw = True
End With
With Picture1
.Top = 0
.Height = 20000
.Width = Pic.Width - VScroll1.Width
.Left = 0
.AutoRedraw = True
End With
With VScroll1
.Height = Pic.Height
.Left = Picture1.Width
.Top = 0
End With
华宁编号 = hnbh(工程目录.Text)
n120文件 = zk120(华宁编号, 钻孔号t.Text)
dcsj文件 = dcsj(华宁编号)
End Sub
Private Sub Grid1_DblClick()
 '   Move   the   text   box   to   the   current   grid   cell:
  Text2.Top = Grid1.CellTop + Grid1.Top
  Text2.Left = Grid1.CellLeft + Grid1.Left
  '   Save   the   position   of   the   grids   Row   and   Col   for   later:
  gRow = Grid1.Row
  gCol = Grid1.Col
  '   Make   text   box   same   size   as   current   grid   cell:
  Text2.Width = Grid1.CellWidth - 2 * Screen.TwipsPerPixelX
  Text2.Height = Grid1.CellHeight - 2 * Screen.TwipsPerPixelY
  '   Transfer   the   grid   cell   text:
  Text2.Text = Grid1.Text
  '   Show   the   text   box:
  Text2.Visible = True
  Text2.ZOrder 0     '   把   Text1   放到最前面！
  Text2.SetFocus
End Sub

''-------------------------钻孔分层表格功能——————————————————————－
Private Sub Grid1_KeyUp(KeyCode As Integer, Shift As Integer)
 If KeyCode = vbKeyDelete Then
  Grid1.Text = ""
  End If
End Sub

Private Sub Grid1_KeyPress(KeyAscii As Integer)
  '   Move   the   text   box   to   the   current   grid   cell:
  Text2.Top = Grid1.CellTop + Grid1.Top
  Text2.Left = Grid1.CellLeft + Grid1.Left
  '   Save   the   position   of   the   grids   Row   and   Col   for   later:
  gRow = Grid1.Row
  gCol = Grid1.Col
  '   Make   text   box   same   size   as   current   grid   cell:
  Text2.Width = Grid1.CellWidth - 2 * Screen.TwipsPerPixelX
  Text2.Height = Grid1.CellHeight - 2 * Screen.TwipsPerPixelY
  '   Transfer   the   grid   cell   text:
  Text2.Text = Grid1.Text
  '   Show   the   text   box:
  Text2.Visible = True
  Text2.ZOrder 0     '   把   Text1   放到最前面！
  Text2.SetFocus
  '   Redirect   this   KeyPress   event   to   the   text   box:
  If KeyAscii <> ASC_ENTER Then
  SendKeys Chr$(KeyAscii)
  End If
  End Sub
  
Private Sub Picture1_DblClick()
i = 1
Do While Grid1.TextMatrix(i, 2) <> ""
i = i + 1
Loop
Grid1.TextMatrix(i, 2) = Text1.Text
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Text1.Text = Format((15000 - Y) / 1000 + qd / 10 - 16, "##.#")
Line1.Y1 = Y
Line1.Y2 = Y
Line1.Visible = True
End Sub

  Private Sub Text2_KeyPress(KeyAscii As Integer)
    If KeyAscii = ASC_ENTER Then
  Grid1.SetFocus   '   Set   focus   back   to   grid,   see   Text_LostFocus.
  KeyAscii = 0       '   Ignore   this   KeyPress.
  End If
  End Sub
       
Private Sub Text2_KeyUp(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
  Case 37
  If Grid1.Col = 2 Then
  Grid1.Col = Grid1.Col - 1
  End If
  Grid1.SetFocus
  KeyCode = 0
  Case 39
  If Grid1.Col = 1 Then
  Grid1.Col = Grid1.Col + 1
  End If
    Grid1.SetFocus
    KeyCode = 0
  Case 38
  If Grid1.Row <= 19 Then
  Grid1.Row = Grid1.Row - 1
  End If
    Grid1.SetFocus
    KeyCode = 0
  Case 40
  If Grid1.Row >= 1 Then
  Grid1.Row = Grid1.Row + 1
  End If
    Grid1.SetFocus
    KeyCode = 0
 End Select
End Sub

  Private Sub Text2_LostFocus()
  Dim tmpRow     As Integer
  Dim tmpCol     As Integer
  '   Save   current   settings   of   Grid   Row   and   col.   This   is   needed   only   if
  '   the   focus   is   set   somewhere   else   in   the   Grid.
  tmpRow = Grid1.Row
  tmpCol = Grid1.Col
  '   Set   Row   and   Col   back   to   what   they   were   before   Text1_LostFocus:
  Grid1.Row = gRow
  Grid1.Col = gCol
  Grid1.Text = Text2.Text       '   Transfer   text   back   to   grid.
  Text2.SelStart = 0       '   Return   caret   to   beginning.
  Text2.SelLength = Len(Text2.Text)
  Text2.Visible = False       '   Disable   text   box.
  '   Return   row   and   Col   contents:
  Grid1.Row = tmpRow
  Grid1.Col = tmpCol
  End Sub
''-------------------------钻孔分层表格功能——————————————————————－

Private Sub VScroll1_Change()
Picture1.Top = -VScroll1.Value
End Sub