form1.frm

绘制等高线的很好控件.很是实用.希望以后多多交流.

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{B62F5114-F3ED-48CA-952E-390E9EC8E86B}#1.0#0"; "ViContour45.ocx"
Begin VB.Form Form1 
   Caption         =   "Demo for ViSC Contour 1.0"
   ClientHeight    =   5415
   ClientLeft      =   165
   ClientTop       =   855
   ClientWidth     =   6810
   LinkTopic       =   "Form1"
   ScaleHeight     =   5415
   ScaleWidth      =   6810
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin ViContour1.ViContour ViContour1 
      Height          =   3255
      Left            =   1680
      TabIndex        =   0
      Top             =   960
      Width           =   3975
      _ExtentX        =   7011
      _ExtentY        =   5741
   End
   Begin MSComDlg.CommonDialog CDialog1 
      Left            =   2520
      Top             =   1920
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.Menu idm_Open 
      Caption         =   "Open"
      Begin VB.Menu idm_OpenPicture 
         Caption         =   "Open Picture"
      End
      Begin VB.Menu idm_OpenData 
         Caption         =   "Open Data"
      End
      Begin VB.Menu idm_SavePicture 
         Caption         =   "Save Picture"
      End
      Begin VB.Menu idm_SaveData 
         Caption         =   "Save Data"
      End
      Begin VB.Menu idm_Sep1 
         Caption         =   "-"
      End
      Begin VB.Menu idm_Demo1 
         Caption         =   "Demo 1"
      End
      Begin VB.Menu idm_Demo2 
         Caption         =   "Demo 2"
      End
      Begin VB.Menu idm_Demo3 
         Caption         =   "Demo 3"
      End
      Begin VB.Menu idm_Demo4 
         Caption         =   "Demo 4"
      End
      Begin VB.Menu idm_Second 
         Caption         =   "Second"
      End
      Begin VB.Menu idm_Sep2 
         Caption         =   "-"
      End
      Begin VB.Menu idm_Exit 
         Caption         =   "Exit"
      End
   End
   Begin VB.Menu idm_Contour 
      Caption         =   "Contour"
      Begin VB.Menu idm_ContourLines 
         Caption         =   "Contour Lines"
      End
      Begin VB.Menu idm_ContourArea 
         Caption         =   "Contour Area"
      End
      Begin VB.Menu idm_ContourPicture 
         Caption         =   "Contour Picture"
      End
      Begin VB.Menu idm_PicContour 
         Caption         =   "Picture Contour"
      End
   End
   Begin VB.Menu idm_Surface3D 
      Caption         =   "Surface"
      Begin VB.Menu idm_3DShow 
         Caption         =   "3D Show"
      End
      Begin VB.Menu idm_PlotMode 
         Caption         =   "Plot Mode"
         Shortcut        =   ^M
      End
      Begin VB.Menu idm_RotateX 
         Caption         =   "Rotate X"
         Shortcut        =   ^X
      End
      Begin VB.Menu idm_RotateY 
         Caption         =   "Rotate Y"
         Shortcut        =   ^Y
      End
      Begin VB.Menu idm_RotateZ 
         Caption         =   "Rotate Z"
         Shortcut        =   ^Z
      End
      Begin VB.Menu idm_Restore 
         Caption         =   "Restore"
      End
      Begin VB.Menu idm_ZoomPlus 
         Caption         =   "Zoom(+)"
         Shortcut        =   ^U
      End
      Begin VB.Menu idm_ZoomMinus 
         Caption         =   "Zoom(-)"
         Shortcut        =   ^D
      End
   End
   Begin VB.Menu idm_Edit 
      Caption         =   "Edit"
      Begin VB.Menu idm_Copy 
         Caption         =   "Copy"
      End
      Begin VB.Menu idm_Paste 
         Caption         =   "Paste"
      End
      Begin VB.Menu idm_ClearGraph 
         Caption         =   "Clear"
      End
   End
   Begin VB.Menu idm_Options 
      Caption         =   "Options"
      Begin VB.Menu idm_ThinLine 
         Caption         =   "Thin Line"
         Checked         =   -1  'True
      End
      Begin VB.Menu idm_Grid 
         Caption         =   "Grid"
         Checked         =   -1  'True
      End
      Begin VB.Menu idm_ColorBar 
         Caption         =   "ColorBar"
         Checked         =   -1  'True
      End
      Begin VB.Menu idm_ColorMap 
         Caption         =   "ColorMap"
         Begin VB.Menu idm_HSV 
            Caption         =   "HSV"
            Checked         =   -1  'True
         End
         Begin VB.Menu idm_Hot 
            Caption         =   "HOT"
         End
         Begin VB.Menu idm_Pink 
            Caption         =   "Pink"
         End
         Begin VB.Menu idm_Gray 
            Caption         =   "Gray"
         End
         Begin VB.Menu idm_cool 
            Caption         =   "Cool"
         End
         Begin VB.Menu idm_Bone 
            Caption         =   "Bone"
         End
         Begin VB.Menu idm_Copper 
            Caption         =   "Copper"
         End
      End
      Begin VB.Menu idm_GridColor 
         Caption         =   "Grid Color"
      End
      Begin VB.Menu idm_MeshColor 
         Caption         =   "Mesh Color"
      End
      Begin VB.Menu idm_Backcolor 
         Caption         =   "Backcolor"
      End
      Begin VB.Menu idm_NumLayers 
         Caption         =   "Num of Layers"
      End
      Begin VB.Menu idm_InterpRows 
         Caption         =   "Interp Rows"
      End
      Begin VB.Menu idm_InterpCols 
         Caption         =   "Interp Cols"
      End
   End
   Begin VB.Menu idm_Chinese 
      Caption         =   "Chinese"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public StartDir As String
Public Mode3D As Integer
Public xAng As Integer, yAng As Integer, zAng As Integer
Public DefaultFile As String
Public isActive As Boolean
Public isChinese As Integer

Private Sub Form_Activate()
  If isActive = False Then
     isActive = True
     If FileExist(DefaultFile) Then
        Call LoadData(DefaultFile)
     End If
  End If
  Call setChinese
End Sub

Private Function FileExist(F As String) As Boolean
   On Error Resume Next
   Open F For Input As #1
   If Err = 0 Then
      Close #1
      FileExist = True
   Else
      FileExist = False
   End If
End Function
'Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Sub Form_Load()
   Dim cFname As String, eFname As String
   
   StartDir = CurDir
   If Right(StartDir, 1&) <> "\" Then
      StartDir = StartDir & "\"
   End If
   cFname = StartDir & "DOT16.HZK"
   eFname = StartDir & "DOT8.HZK"
   
   isActive = False
   ViContour1.GridType True, True, True
   ViContour1.BKColor = &H0&
   ViContour1.GridColor = &HFF0000
   
   ViContour1.ChineseFont = cFname
   ViContour1.EnglishFont = eFname

   Mode3D = 2
   xAng = ViContour1.xAngle
   yAng = ViContour1.yAngle
   zAng = ViContour1.zAngle
   DefaultFile = Command
   ViContour1.MeshColor = &HFF00FF
   
   Call setPanel
   Call ViContour1.InitBuffer
End Sub

Private Sub Form_Resize()
   Call setPanel
End Sub

Private Sub Form_Unload(Cancel As Integer)
  ViContour1.CloseBuffer
  End
End Sub

Private Sub idm_3DShow_Click()
  ViContour1.Clear ViContour1.BKColor
  ViContour1.MakeSurface CLng(Mode3D)
  ViContour1.DisplayBuffer
End Sub

Private Sub idm_Backcolor_Click()
  Dim c As Long
  
  c = getSelColor
  If c <> -1 Then
     ViContour1.BKColor = c
  End If
End Sub

Private Sub idm_Bone_Click()
  DelColormap
  idm_Bone.Checked = True
  ViContour1.ColorMap = 5
End Sub

Private Sub idm_Chinese_Click()
  If isChinese = 0 Then
     isChinese = 1
  Else
     isChinese = 0
  End If
  Call setChinese
End Sub

Private Sub idm_ClearGraph_Click()
  ViContour1.Clear ViContour1.BKColor
  ViContour1.DisplayBuffer
End Sub

Private Sub idm_ColorBar_Click()
   idm_ColorBar.Checked = Not idm_ColorBar.Checked
   ViContour1.ColorBar = idm_ColorBar.Checked
End Sub

Private Sub idm_ContourArea_Click()
  ViContour1.Clear ViContour1.BKColor
  ViContour1.MakeContour 1
End Sub

Private Sub idm_ContourLines_Click()
  ViContour1.Clear ViContour1.BKColor
  ViContour1.MakeContour 0
End Sub

Private Sub idm_ContourPicture_Click()
  ViContour1.Clear ViContour1.BKColor
  ViContour1.MakeContour 2
End Sub

Private Sub idm_cool_Click()
  DelColormap
  idm_cool.Checked = True
  ViContour1.ColorMap = 4
End Sub

Private Sub idm_Copper_Click()
  DelColormap
  idm_Copper.Checked = True
  ViContour1.ColorMap = 6
End Sub

Private Sub idm_Copy_Click()
   ViContour1.CopyImage
End Sub

Private Sub idm_Demo1_Click()
   Call ViContour1.Demo(0)
   ViContour1.DisplayBuffer
End Sub

Private Sub idm_Demo2_Click()
   Call ViContour1.Demo(1)
   ViContour1.DisplayBuffer
End Sub

Private Sub idm_Demo3_Click()
   Call ViContour1.Demo(2)
   ViContour1.DisplayBuffer
End Sub

Private Sub idm_Demo4_Click()
    Dim z(0 To 2500) As Single
    Dim x(0 To 50) As Single
    Dim y(0 To 50) As Single
    Dim i As Long, j As Long
    Dim z1 As Single, z2 As Single
    
    z1 = -10
    z2 = 10
    For i = 0 To 49
      x(i) = -10 + 20! / 49 * i
      For j = 0 To 49
        If i = 0 Then
           y(j) = -10 + 20! / 49 * j
        End If
        If x(i) = 0! And y(j) = 0! Then
           z(i * 50 + j) = 1
        Else
           z(i * 50 + j) = Sin(Sqr(x(i) * x(i) + y(j) * y(j))) / Sqr(x(i) * x(i) + y(j) * y(j))
        End If
        If z(i * 50 + j) > z2 Then
           z2 = z(i * 50 + j)
        End If
        If z(i * 50 + j) < z1 Then
           z1 = z(i * 50 + j)
        End If
      Next j
    Next i
    
    
    ViContour1.SampleData x, y, z, 50&, 50&
    ViContour1.zMin = z1
    ViContour1.zMax = z2
    ViContour1.numLayers = 25
    ViContour1.Clear ViContour1.BKColor
    
    ViContour1.MakeSurface 2&
    ViContour1.DisplayBuffer
End Sub

Private Sub idm_Exit_Click()
  Unload Me
End Sub

Private Sub idm_Gray_Click()
  DelColormap
  idm_Gray.Checked = True
  ViContour1.ColorMap = 3
End Sub

Private Sub idm_Grid_Click()
   idm_Grid.Checked = Not idm_Grid.Checked
   If idm_Grid.Checked Then
      ViContour1.GridType True, True, True
   Else
      ViContour1.GridType True, False, False
   End If
End Sub

Private Sub idm_GridColor_Click()
   Dim c As Long
   
   c = getSelColor
   If c <> -1 Then
      ViContour1.GridColor = c
   End If
End Sub

Private Sub idm_Hot_Click()
  DelColormap
  idm_Hot.Checked = True
  ViContour1.ColorMap = 1
End Sub

Private Sub idm_HSV_Click()
  DelColormap
  idm_HSV.Checked = True
  ViContour1.ColorMap = 0
End Sub

Private Sub idm_InterpCols_Click()
  Dim c As Long
  Dim vStr As String
  
  c = ViContour1.ColsInterp
  vStr = InputBox("Cols of Interpolation", "Cols of Interpolation", c)
  If vStr <> "" Then
     c = Val(vStr)
     If c >= 10 And c <= 500 Then
        ViContour1.ColsInterp = c
     End If
  End If
End Sub