mapxutils.bas

GIS地理信息系统开发。大名鼎鼎的MAPX＋VisualBasic6.0软件开发

Attribute VB_Name = "MapXUtils"
Option Explicit

' This sample application and corresponding sample code is provided
' for example purposes only.  It has not undergone rigorous testing
' and as such should not be shipped as part of a final application
' without extensive testing on the part of the organization releasing
' the end-user product.

Const P_RED As Byte = 1
Const P_GREEN As Byte = 2
Const P_BLUE As Byte = 3

Type RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

Public Type LayerDescr
  Name As String
  NewLayer As Boolean
  Visible As Boolean
  Selectable As Boolean
  AutoLabel As Boolean
  InitPos As Integer
  LabelProp As LabelProperties
  StyleProp As Style
  LabelChanged As Boolean
  StyleChanged As Boolean
  ZoomLayer As Boolean
  ZoomMin As Double
  ZoomMax As Double
  Override As Boolean
End Type

Public Type ThemeDescr
  LayerName As String
  DataSetName As String
  ThemeName As String
  ThemeString As String
End Type

Public Type DocInfo
  cbSize As Integer
  lpszDocName As String
  lpszOutput As Long
End Type

Declare Function GetWindowRect Lib "user32.dll" (ByVal hw As Long, lprc As RECT) As Long

Declare Function GetSystemMetrics Lib "user32.dll" (ByVal Index As Long) As Long

Declare Function MoveWindow Lib "user32.dll" (ByVal hw As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal fRepaint As Long) As Long

Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal param As Long) As Long

Declare Function StartDoc Lib "gdi32.dll" Alias "StartDocA" (ByVal hdcDC As Long, ByRef tDocInfo As DocInfo) As Long

Declare Function EndDoc Lib "gdi32.dll" (ByVal hdcDC As Long) As Long

Declare Function EndPage Lib "gdi32.dll" (ByVal hdcDC As Long) As Long

Global ld() As LayerDescr, DeletedLayers() As String

'Declare Function SendMessage Lib "user32.dll" (ByVal hw As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
'Declare Sub CopyMemory Lib "kernel32.dll" (Dest As Long, Src As Long, ByVal length As Long)

Public Sub FormToCenter(ByVal lFormWnd As Long)
    Dim r As RECT, cx, cy, nx, ny, res As Long
    
    cx = GetSystemMetrics(0)
    cy = GetSystemMetrics(1)
    
    res = GetWindowRect(lFormWnd, r)
    
    nx = (cx - r.right + r.left) \ 2
    ny = (cy - r.bottom + r.top) \ 2
    
    res = MoveWindow(lFormWnd, nx, ny, r.right - r.left, r.bottom - r.top, 1)
    
End Sub

Public Sub FillThemes(ThemesArray() As ThemeDescr, Map As Map)
  Dim i As Integer, j As Integer, iThemesNum As Integer
  
  iThemesNum = 0
  ReDim ThemesArray(8)

  For i = 1 To Map.Datasets.Count
    For j = 1 To Map.Datasets(i).Themes.Count
      iThemesNum = iThemesNum + 1
      If iThemesNum > UBound(ThemesArray) Then
        ReDim Preserve ThemesArray(UBound(ThemesArray) + 8)
      End If
      ThemesArray(iThemesNum).LayerName = Map.Datasets(i).Layer.Name
      ThemesArray(iThemesNum).DataSetName = Map.Datasets(i).Name
      ThemesArray(iThemesNum).ThemeName = Map.Datasets(i).Themes(j).Name
      ThemesArray(iThemesNum).ThemeString = ThemesArray(iThemesNum).LayerName & " - (" & ThemesArray(iThemesNum).DataSetName & ") " & MakeThemeTypeStr(Map.Datasets(i).Themes(j).Type) & " " & ThemesArray(iThemesNum).ThemeName
    Next
  Next
  ReDim Preserve ThemesArray(iThemesNum)
End Sub

Public Function MakeThemeTypeStr(ByVal ThemeType As Integer) As String
  Select Case ThemeType
    Case miThemeRanged
      MakeThemeTypeStr = "Ranges by"
    Case miThemeBarChart
      MakeThemeTypeStr = "Bars with"
    Case miThemePieChart
      MakeThemeTypeStr = "Pies with"
    Case miThemeGradSymbol
      MakeThemeTypeStr = "Graduated by"
    Case miThemeDotDensity
      MakeThemeTypeStr = "Dot density with"
    Case miThemeIndividualValue
      MakeThemeTypeStr = "Ind. value with"
  End Select
End Function

Public Sub Fill_HSV_Colors(ByVal BeginColor As Long, ByVal EndColor As Long, ByVal rCount As Integer, lResRGB() As Long)
  Dim h1 As Double, h2 As Double, hs As Double, ch As Double
  Dim s1 As Double, s2 As Double, ss As Double, cs As Double
  Dim v1 As Double, v2 As Double, vs As Double, cv As Double
  Dim i As Integer
  
  lResRGB(1) = BeginColor
  lResRGB(rCount) = EndColor
  
  If rCount <= 2 Then
    Exit Sub
  End If
  
  RGB2HSV BeginColor, h1, s1, v1
  RGB2HSV EndColor, h2, s2, v2
  
  ss = (s2 - s1) / (rCount - 1)
  vs = (v2 - v1) / (rCount - 1)
  If Abs(h2 - h1) > 180 Then
    If h1 < h2 Then
      hs = (h2 - h1 - 360) / (rCount - 1)
    Else
      hs = (360 - (h1 - h2)) / (rCount - 1)
    End If
  Else
    hs = (h2 - h1) / (rCount - 1)
  End If
  ch = h1
  cs = s1
  cv = v1
  
  For i = 2 To rCount - 1
    ch = ch + hs
    If ch < 0 Then
      ch = ch + 360
    End If
    If ch > 360 Then
      ch = ch - 360
    End If
    cs = cs + ss
    cv = cv + vs
    HSV2RGB ch, cs, cv, lResRGB(i)
  Next
End Sub

Public Function RGB_Color(ByVal RGB_Src As Long, ByVal Which As Byte) As Byte
  Select Case Which
    Case P_RED
      RGB_Color = RGB_Src And 255
    Case P_GREEN
      RGB_Color = (RGB_Src And 65280) / 256
    Case P_BLUE
      RGB_Color = (RGB_Src And 16711680) / 65536
  End Select
End Function

Public Sub RGB2HSV(ByVal lRGB As Long, h As Double, s As Double, v As Double)
  Dim r As Double, g As Double, b As Double, dMin As Double, dMax As Double, d As Double

' h = [0;360), s, v = [0,1]
  r = RGB_Color(lRGB, P_RED) / 255#
  g = RGB_Color(lRGB, P_GREEN) / 255#
  b = RGB_Color(lRGB, P_BLUE) / 255#
  
' r, g, b = [0,1]
  dMax = r
  If dMax < g Then
    dMax = g
  End If
  If dMax < b Then
    dMax = b
  End If
' dMax = max(r,g,b)
  dMin = r
  If dMin > g Then
    dMin = g
  End If
  If dMin > b Then
    dMin = b
  End If
' dMin = min(r,g,b)
  v = dMax
  If dMax <> 0 Then
    s = (dMax - dMin) / dMax
  Else
    s = 0
  End If
  If s = 0 Then
    h = 0
    Exit Sub
  Else
    d = dMax - dMin
  End If
  If r = dMax Then
    h = (g - b) / d
  End If
  If g = dMax Then
    h = 2 + (b - r) / d
  End If
  If b = dMax Then
    h = 4 + (r - g) / d
  End If
  h = h * 60
  If h < 0 Then
    h = h + 360
  End If
End Sub

Public Sub HSV2RGB(ByVal h As Double, ByVal s As Double, ByVal v As Double, lRGB As Long)
  Dim r As Double, g As Double, b As Double, hh As Double, i As Integer, f As Double, p As Double, q As Double, t As Double

  If s = 0 Then
    r = v
    g = v
    b = v
    lRGB = RGB(r * 255#, g * 255#, b * 255#)
    Exit Sub
  End If
  If h = 360 Then
    hh = 0
  Else
    hh = h / 60#
  End If
  i = Int(hh)
  f = hh - i
  p = v * (1 - s)
  q = v * (1 - s * f)
  t = v * (1 - s * (1 - f))
  Select Case i
    Case 0
      r = v
      g = t
      b = p
    Case 1
      r = q
      g = v
      b = p
    Case 2
      r = p
      g = v
      b = t
    Case 3
      r = p
      g = q
      b = v
    Case 4
      r = t
      g = p
      b = v
    Case 5
      r = v
      g = p
      b = q
  End Select
  lRGB = RGB(r * 255#, g * 255#, b * 255#)
End Sub

Public Function GetDatasetNum(ds As Dataset, mMap As Map) As Integer
  Dim sName As String, i As Integer
  
  On Error GoTo NoDataset
  sName = ds.Name
  On Error GoTo 0
  For i = 1 To mMap.Datasets.Count
    If sName = mMap.Datasets(i).Name Then
      GetDatasetNum = i
      Exit Function
    End If
  Next
NoDataset:
  GetDatasetNum = 0
End Function

Public Function GetFieldNum(ds As Dataset, Fld As MapXLib.Field) As Integer
  Dim sName As String, i As Integer
  
  On Error GoTo NoField
  sName = Fld.Name
  On Error GoTo 0
  For i = 1 To ds.Fields.Count
    If sName = ds.Fields(i).Name Then
      GetFieldNum = i
      Exit Function
    End If
  Next
NoField:
  GetFieldNum = 0
End Function

Public Sub PrintMapX(mMap As Map)
  Dim iScaleMode As Integer

  iScaleMode = mMap.Container.ScaleMode
  mMap.Container.ScaleMode = 6

  On Error GoTo PrinterError
  Printer.Print " "
  Printer.CurrentX = 0
  Printer.CurrentY = 0
  mMap.PrintMap Printer.hdc, 0, 0, mMap.Width * 100, mMap.Height * 100
  Printer.NewPage
  Printer.EndDoc
  mMap.Container.ScaleMode = iScaleMode
  Exit Sub
PrinterError:
  MsgBox "There is a problem printing on your printer", vbOKOnly, "Print Map"
  Exit Sub
End Sub

Public Sub CopyMapXFont(dstFont As StdFont, ByVal srcFont As StdFont)
  dstFont.Name = srcFont.Name
  dstFont.Size = srcFont.Size
  dstFont.Weight = srcFont.Weight
  dstFont.Bold = srcFont.Bold
  dstFont.Italic = srcFont.Italic
  dstFont.Strikethrough = srcFont.Strikethrough
  dstFont.Underline = srcFont.Underline
  dstFont.Charset = srcFont.Charset
End Sub