frmmain.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

      Begin VB.Label Label1 
         Caption         =   "渐变填充中心点的水平偏移量："
         Height          =   435
         Index           =   0
         Left            =   135
         TabIndex        =   10
         Top             =   450
         Width           =   1350
      End
   End
   Begin VB.Frame Frame1 
      Height          =   4995
      Left            =   0
      TabIndex        =   0
      Top             =   405
      Width           =   7890
      Begin SuperMapLib.SuperMap SuperMap 
         Height          =   4830
         Left            =   45
         TabIndex        =   1
         Top             =   120
         Width           =   7800
         _Version        =   327682
         _ExtentX        =   13758
         _ExtentY        =   8520
         _StockProps     =   160
         Appearance      =   1
      End
   End
   Begin SuperMapLib.SuperWorkspace SuperWorkspace 
      Left            =   480
      Top             =   795
      _Version        =   327682
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'=====================================SuperMap Objects示范工程说明=======================================
'
'功能简介：示范SuperMap Objects图层风格的渐变填充和半透明填充效果
'所用控件：SuperMap控件、SuperWorkspace控件
'所用数据：..\Data\World\world.sdb
'操作说明：
'         1、点击“>>”按钮，在扩展的窗体上设置填充风格，
'         2、点击“设置填充效果”按钮，系统将按照所设置的“渐变填充”
'            （或者“透明填充”）对图层进行风格设置。
'
'===================================SuperMap Objects示范工程说明结束=====================================

Option Explicit

Private Sub cmdBrushStyle_Click() '对图层设置渐变填充或者透明填充
    If SuperMap.Layers.Count < 1 Then Exit Sub
    
    Dim objLayer As soLayer
    Dim objStyle As soStyle
    Dim strTemp As String
    Dim iTmp As Double
    
    Set objLayer = SuperMap.Layers.Item(1)
    Set objStyle = objLayer.Style
    
    If optGradient.Value = True Then
        objStyle.BrushBackTransparent = False
        objStyle.BrushColor = lblFColor.BackColor
        objStyle.BrushBackColor = lblBackColor.BackColor
        objStyle.BrushGradientAngle = CDbl(txtAngle.Text)
        
        strTemp = Trim(txtXoffset.Text)
        If strTemp = "" Then
            iTmp = 0
        Else
            iTmp = Int(strTemp)
            If iTmp > 32767 Then
                iTmp = 0
            End If
        End If
        objStyle.BrushGradientCenterOffsetX = iTmp
        
        strTemp = Trim(txtYoffset.Text)
        If strTemp = "" Then
            iTmp = 0
        Else
            iTmp = Int(strTemp)
            If iTmp > 32767 Then
                iTmp = 0
            End If
        End If
        objStyle.BrushGradientCenterOffsetY = iTmp
        
        objStyle.BrushOpaqueRate = 100
        Select Case cmbList.ListIndex
            Case 0
                objStyle.BrushGradientMode = scbGradientRadial
            Case 1
                objStyle.BrushGradientMode = scbGradientSquare
            Case 2
                objStyle.BrushGradientMode = scbGradientConical
            Case 3
                objStyle.BrushGradientMode = scbGradientNone
        End Select
    Else
        objStyle.BrushColor = lblFColor.BackColor
        objStyle.BrushBackTransparent = True
        objStyle.BrushGradientMode = scbGradientNone
        objStyle.BrushOpaqueRate = slOpaqueRate.Value
    End If
    
    Set objLayer.Style = objStyle
    SuperMap.Refresh
    
    Me.Width = 7995
    cmdSet.Caption = ">>"
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdPan_Click() '漫游
    SuperMap.Action = scaPan
End Sub

Private Sub cmdSelect_Click() '选择
    SuperMap.Action = scaSelect
End Sub

Private Sub cmdSet_Click() '扩展窗体进行风格设置
    If cmdSet.Caption = ">>" Then
        cmdSet.Caption = "<<"
        Me.Width = 10470
    ElseIf (cmdSet.Caption = "<<") Then
        cmdSet.Caption = ">>"
        Me.Width = 7995
    End If
End Sub

Private Sub cmdViewEnt_Click() '全幅显示
    SuperMap.ViewEntire
    SuperMap.Refresh
End Sub

Private Sub cmdZoomFree_Click() '自由缩放
    SuperMap.Action = scaZoomFree
End Sub

Private Sub cmdZoomIn_Click() '放大
    SuperMap.Action = scaZoomIn
End Sub

Private Sub cmdZoomOut_Click() '缩小
    SuperMap.Action = scaZoomOut
End Sub

Private Sub Form_Load()
    Dim objDs As soDataSource
    Dim objDt As soDataset
    Dim objStyle As New soStyle
    
    SuperMap.Connect SuperWorkspace.Handle
    Set objDs = SuperWorkspace.OpenDataSource(App.Path & "\..\Data\World\World.sdb", "World", sceSDBPlus, True)
    If objDs Is Nothing Then Exit Sub
    
    Set objDt = objDs.Datasets("World")
    If objDt Is Nothing Then Exit Sub
    
    SuperMap.Layers.AddDataset objDt, True
    objStyle.BrushColor = RGB(128, 128, 0)
    objStyle.PenColor = RGB(128, 128, 0)
    objStyle.BrushStyle = 3
    Set SuperMap.selection.Style = objStyle
    
    SuperMap.ViewEntire
    SuperMap.Refresh
    
    cmbList.ListIndex = 0
    Me.Width = 7995
    
    Set objStyle = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SuperMap.Close
    SuperMap.Disconnect
    SuperWorkspace.Close
End Sub

Private Sub lblBackColor_Click()
    dlgColor.Color = lblBackColor.BackColor
    dlgColor.ShowColor
    lblBackColor.BackColor = dlgColor.Color
End Sub

Private Sub lblFColor_Click()
    dlgColor.Color = lblFColor.BackColor
    dlgColor.ShowColor
    lblFColor.BackColor = dlgColor.Color
End Sub

Private Sub txtAngle_Change()
    If Trim(txtAngle.Text = "") Then txtAngle.Text = 0
    If Int(txtAngle.Text) > 100 Then
        txtAngle.Text = 100
    End If
End Sub

Private Sub txtAngle_KeyPress(KeyAscii As Integer)
    If (KeyAscii > Asc("9")) Or (KeyAscii < Asc("0")) Then
        If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub

Private Sub txtXoffset_Change()
    If Trim(txtXoffset.Text = "") Then txtXoffset.Text = 0
End Sub

Private Sub txtXoffset_KeyPress(KeyAscii As Integer)
    If (KeyAscii > Asc("9")) Or (KeyAscii < Asc("0")) Then
        If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub

Private Sub txtYoffset_Change()
    If Trim(txtYoffset.Text = "") Then txtYoffset.Text = 0
End Sub

Private Sub txtYoffset_KeyPress(KeyAscii As Integer)
    If (KeyAscii > Asc("9")) Or (KeyAscii < Asc("0")) Then
        If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub