form1.frm

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

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

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

Private Sub idm_NumLayers_Click()
   Dim vStr As String
   Dim hh As Integer
   
   hh = ViContour1.numLayers
   vStr = InputBox("Number of height layers", "Layers selection", hh)
   If vStr = "" Then
      Exit Sub
   End If
   hh = Val(vStr)
   If hh > 2 And hh < 255 Then
      ViContour1.numLayers = hh
   End If
End Sub

Private Sub idm_OpenData_Click()
   Dim Fname As String
   Dim Sufix As String
   Dim iRet As Long
   
   iRet = 0
   Fname = getOpenFile(1)
   If Fname <> "" Then
      Sufix = Right(Fname, 4&)
      Sufix = LCase(Sufix)
      Me.MousePointer = 11
      Select Case Sufix
         Case ".txt"
           iRet = ViContour1.OpenTxtMatrix(Fname)
         Case ".dat"
           iRet = ViContour1.OpenTxtAMatrix(Fname)
         Case ".tdt"
           iRet = ViContour1.OpenTxtSeries(Fname)
         Case Else
           iRet = ViContour1.OpenTxtAMatrix(Fname)
      End Select
      Me.MousePointer = 0
      
      If iRet <= 0 Then
         MsgBox "Open data file error .", vbOKOnly + vbInformation, "Message"
      Else
         ViContour1.Clear ViContour1.BKColor
         ViContour1.MakeContour 0
      End If
   End If
End Sub

Private Sub idm_OpenPicture_Click()
   Dim Fname As String
   
   Fname = getOpenFile(0)
   If Fname <> "" Then
      If ViContour1.OpenPicture(Fname) <= 0 Then
         MsgBox "Error in open picture file !", vbOKOnly + vbInformation, "Message"
      End If
   End If
End Sub

Public Function getOpenFile(mode As Integer) As String
   Dim Fname As String
   
   With CDialog1
      .CancelError = True
      If mode = 0 Then
         .Filter = "Pictures|*.jpg;*.bmp;*.tga;*.pcx;*.tif|All Files(*.*)|*.*"
      Else
         .Filter = "Data(*.tdt,*.dat,*.txt)|*.tdt;*.dat;*.txt|All Files(*.*)|*.*"
      End If
      
      On Error Resume Next
      .ShowOpen
      If Err = 0 Then
         Fname = .FileName
      Else
         Fname = ""
      End If
      getOpenFile = Fname
   End With
End Function

Public Function getSaveFile(mode As Integer) As String
   Dim Fname As String
   
   With CDialog1
      .CancelError = True
      If mode = 0 Then
         .Filter = "Pictures|*.jpg;*.bmp;*.tga;*.pcx;*.tif|JPEG Files(*.jpg)|*.jpg|Bitmap(*.bmp)|*.bmp|All Files(*.*)|*.*"
      Else
         .Filter = "Data(*.dat,*.txt)|*.dat;*.txt|DAT Files(*.dat)|*.dat|TXT Files(*.txt)|*.txt|All Files(*.*)|*.*"
      End If
      
      On Error Resume Next
      .ShowSave
      If Err = 0 Then
         Fname = .FileName
      Else
         Fname = ""
      End If
      getSaveFile = Fname
   End With
End Function

Private Sub setPanel()
   With ViContour1
      .Left = 0
      .Top = 0
      .Width = Me.ScaleWidth
      .Height = Me.ScaleHeight
   End With
End Sub

Private Sub idm_Paste_Click()
   ViContour1.PasteImage
   ViContour1.DisplayBuffer
End Sub

Private Sub idm_PicContour_Click()
   ReDim v(0 To ViContour1.numLayers) As Single
   Dim i As Long
   Dim v1 As Single
   
   v1 = 255! / (ViContour1.numLayers - 1)
   For i = 0 To ViContour1.numLayers - 1
      v(i) = ViContour1.zLayerValue(CInt(i))
      ViContour1.zLayerValue(CInt(i)) = v1 * i
   Next i
   Call ViContour1.MakeContour(3&)
   For i = 0 To ViContour1.numLayers - 1
      ViContour1.zLayerValue(CInt(i)) = v(i)
   Next i
End Sub

Private Sub idm_Pink_Click()
  DelColormap
  idm_Pink.Checked = True
  ViContour1.ColorMap = 2
End Sub

Private Sub idm_PlotMode_Click()
  Mode3D = ((Mode3D + 1) Mod 11)
  If isChinese > 0 Then
     idm_PlotMode.Caption = "三维绘图模式是: " & Mode3D
  Else
     idm_PlotMode.Caption = "Mode3D is " & Mode3D
  End If
  Call idm_3DShow_Click
End Sub

Private Sub idm_Restore_Click()
   ViContour1.xAngle = xAng
   ViContour1.yAngle = yAng
   ViContour1.zAngle = zAng
End Sub

Private Sub idm_RotateX_Click()
   Dim a As Integer
   
   a = ViContour1.xAngle
   a = (a + 360 + 5) Mod 360
   ViContour1.xAngle = a
   Call idm_3DShow_Click
End Sub

Private Sub idm_RotateY_Click()
   Dim a As Integer
   
   a = ViContour1.yAngle
   a = (a + 360 + 5) Mod 360
   ViContour1.yAngle = a
   Call idm_3DShow_Click
End Sub

Private Sub idm_RotateZ_Click()
   Dim a As Integer
   
   a = ViContour1.zAngle
   a = (a + 360 + 5) Mod 360
   ViContour1.zAngle = a
   Call idm_3DShow_Click
End Sub

Private Sub idm_SaveData_Click()
   Dim Fname As String
   Dim iRet As Long
   Dim Sufix As String
   
   Fname = getSaveFile(1)
   If Fname <> "" Then
      Me.MousePointer = 11
      Sufix = LCase(Right(Fname, 4&))
      Select Case Sufix
         Case ".txt"
            iRet = ViContour1.WriteTxtMatrix(Fname, "")
         Case ".dat"
            iRet = ViContour1.WriteTxtAMatrix(Fname, "00.000")
      End Select
      Me.MousePointer = 0
   End If
End Sub

Private Sub idm_SavePicture_Click()
   Dim Fname As String
   Dim iRet As Long
   Dim Fmt As Integer
   Dim Sufix As String
   
   Fname = getSaveFile(0)
   If Fname <> "" Then
      Sufix = Right(Fname, 4&)
      Sufix = LCase(Sufix)
      Select Case Sufix
         Case ".bmp"
            Fmt = 0
         Case ".jpg"
            Fmt = 6
         Case ".tga"
            Fmt = 4
         Case ".pcx"
            Fmt = 1
         Case ".tif"
            Fmt = 3
         Case Else
            Fmt = 0
      End Select
      Me.MousePointer = 11
      iRet = ViContour1.WritePicture(Fname, Fmt)
      Me.MousePointer = 0
   End If
End Sub

Private Sub idm_Second_Click()
   Form2.Show 0, Me
End Sub

Private Sub idm_ThinLine_Click()
   idm_ThinLine.Checked = Not idm_ThinLine.Checked
   If idm_ThinLine.Checked Then
      ViContour1.ThinLine = True
   Else
      ViContour1.ThinLine = False
   End If
End Sub

Private Sub DelColormap()
   idm_HSV.Checked = False
   idm_Hot.Checked = False
   idm_Pink.Checked = False
   idm_Gray.Checked = False
   idm_cool.Checked = False
   idm_Bone.Checked = False
   idm_Copper.Checked = False
End Sub

Private Sub idm_ZoomMinus_Click()
   Dim a As Single
   Dim b As Single
   Dim c As Single
   
   a = ViContour1.xFactor
   b = ViContour1.yFactor
   c = ViContour1.zFactor
   
   a = a / 1.5
   b = b / 1.5
   c = c / 1.5
   ViContour1.xFactor = a
   ViContour1.yFactor = b
   ViContour1.zFactor = c
   
   Call idm_3DShow_Click
End Sub

Private Sub idm_ZoomPlus_Click()
   Dim a As Single
   Dim b As Single
   Dim c As Single
   
   a = ViContour1.xFactor
   b = ViContour1.yFactor
   c = ViContour1.zFactor
   
   a = a * 1.5
   b = b * 1.5
   c = c * 1.5
   ViContour1.xFactor = a
   ViContour1.yFactor = b
   ViContour1.zFactor = c
   Call idm_3DShow_Click
End Sub

Private Function getSelColor() As Long
   Dim c As Long
   
   CDialog1.CancelError = True
   On Error Resume Next
   CDialog1.ShowColor
   If Err = 0 Then
      c = CDialog1.Color
      getSelColor = c
   Else
      getSelColor = -1
   End If
End Function

Public Function LoadData(Fname As String) As Long
      Dim Sufix As String
      Dim iRet As Long
      
      Sufix = Right(Fname, 4&)
      Sufix = LCase(Sufix)
      Me.MousePointer = 11
      Select Case Sufix
         Case ".txt"
           iRet = ViContour1.OpenTxtMatrix(Fname)
         Case ".dat"
           iRet = ViContour1.OpenTxtAMatrix(Fname)
         Case ".tdt"
           iRet = ViContour1.OpenTxtSeries(Fname)
         Case Else
           iRet = ViContour1.OpenTxtAMatrix(Fname)
      End Select
      Me.MousePointer = 0
      
      If iRet > 0 Then
         ViContour1.Clear ViContour1.BKColor
         ViContour1.MakeContour 0
      End If
      LoadData = iRet
End Function

Private Sub setChinese()
   If isChinese = 0 Then
      idm_Open.Caption = "&Open"
      idm_OpenPicture.Caption = "Open Picture"
      idm_OpenData.Caption = "Open Data"
      idm_SavePicture.Caption = "Save Picture"
      idm_SaveData.Caption = "Save Data"
      idm_Demo1.Caption = "Demo one"
      idm_Demo2.Caption = "Demo two"
      idm_Demo3.Caption = "Demo three"
      idm_Demo4.Caption = "Demo four"
      idm_Exit.Caption = "Exit"
      idm_Contour.Caption = "Contour"
      idm_ContourLines.Caption = "Contour Lines"
      idm_ContourPicture.Caption = "Picturize"
      idm_PicContour.Caption = "Picture 's Contour"
      idm_Surface3D.Caption = "Surface"
      idm_3DShow.Caption = "Display Surface"
      idm_PlotMode.Caption = "Change Mode"
      idm_Restore.Caption = "Restore"
      idm_RotateX.Caption = "Rotate x"
      idm_RotateY.Caption = "Rotate y"
      idm_RotateZ.Caption = "Rotate z"
      idm_ZoomPlus.Caption = "Zoom(+)"
      idm_ZoomMinus.Caption = "Zoom(-)"
      idm_Edit.Caption = "Edit"
      idm_Copy.Caption = "Copy"
      idm_Paste.Caption = "Paste"
      idm_ClearGraph.Caption = "Clear"
      idm_Options.Caption = "Options"
      idm_ThinLine.Caption = "Thin contour lines"
      idm_Grid.Caption = "Grid"
      idm_ColorBar.Caption = "Colorbar"
      idm_ColorMap.Caption = "colormap"
      idm_GridColor.Caption = "Grid Color"
      idm_MeshColor.Caption = "Mesh color"
      idm_Backcolor.Caption = "Back Color"
      idm_NumLayers.Caption = "Num of Layers"
      idm_InterpRows.Caption = "Interpolation Rows"
      idm_InterpCols.Caption = "Interpolation Cols"
      idm_ContourArea.Caption = "Contour Fill Area"
      Me.Caption = "Contour Demo"
   Else
      idm_Open.Caption = "打开"
      idm_OpenPicture.Caption = "打开图象文件"
      idm_OpenData.Caption = "打开数据文件"
      idm_SavePicture.Caption = "保存图象"
      idm_SaveData.Caption = "保存数据"
      idm_Demo1.Caption = "演示图形之一"
      idm_Demo2.Caption = "演示图形之二"
      idm_Demo3.Caption = "演示图形之三"
      idm_Demo4.Caption = "演示图形之四"
      idm_Exit.Caption = "退出"
      idm_Contour.Caption = "等高线"
      idm_ContourLines.Caption = "等高线图形"
      idm_ContourPicture.Caption = "图象表示"
      idm_PicContour.Caption = "图象的等高线"
      idm_Surface3D.Caption = "三维图形"
      idm_3DShow.Caption = "显示三维图形"
      idm_PlotMode.Caption = "三维图形模式"
      idm_Restore.Caption = "恢复原来位置"
      idm_RotateX.Caption = "绕x轴旋转"
      idm_RotateY.Caption = "绕y轴旋转"
      idm_RotateZ.Caption = "绕z轴旋转"
      idm_ZoomPlus.Caption = "放大显示"
      idm_ZoomMinus.Caption = "缩小显示"
      idm_Edit.Caption = "编辑"
      idm_Copy.Caption = "复制"
      idm_Paste.Caption = "粘贴"
      idm_ClearGraph.Caption = "清除"
      idm_Options.Caption = "选项"
      idm_ThinLine.Caption = "细线"
      idm_Grid.Caption = "网格"
      idm_ColorBar.Caption = "颜色条"
      idm_ColorMap.Caption = "颜色设置"
      idm_GridColor.Caption = "坐标网格颜色"
      idm_MeshColor.Caption = "网线颜色"
      idm_Backcolor.Caption = "背景颜色"
      idm_NumLayers.Caption = "高度层数"
      idm_InterpRows.Caption = "散乱数据插值行数"
      idm_InterpCols.Caption = "散乱数据插值列数"
      idm_ContourArea.Caption = "填充等高线"
      Me.Caption = "等高线控件演示程序"
   End If
End Sub