frmsavegeoset.frm

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

            Picture         =   "frmSaveGeoset.frx":397E
            Key             =   ""
            Object.Tag             =   "New"
         EndProperty
         BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmSaveGeoset.frx":422C
            Key             =   ""
            Object.Tag             =   "Open"
         EndProperty
         BeginProperty ListImage9 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmSaveGeoset.frx":4ADA
            Key             =   ""
            Object.Tag             =   "SAve"
         EndProperty
      EndProperty
   End
   Begin VB.Menu mnufile 
      Caption         =   "&File"
      Index           =   1
      Begin VB.Menu mnufile1 
         Caption         =   "&New Geoset"
         Index           =   100
         Shortcut        =   ^N
      End
      Begin VB.Menu mnufile1 
         Caption         =   "&Open Geoset"
         Index           =   101
         Shortcut        =   ^O
      End
      Begin VB.Menu mnufile1 
         Caption         =   "&Save Geoset "
         Index           =   102
         Shortcut        =   ^S
      End
      Begin VB.Menu mnufile1 
         Caption         =   "-"
         Index           =   103
      End
      Begin VB.Menu mnufile1 
         Caption         =   "E&xit"
         Index           =   199
      End
      Begin VB.Menu mnufile1 
         Caption         =   "-"
         Index           =   499
         Visible         =   0   'False
      End
      Begin VB.Menu mnufile1 
         Caption         =   ""
         Index           =   500
         Visible         =   0   'False
      End
      Begin VB.Menu mnufile1 
         Caption         =   ""
         Index           =   501
         Visible         =   0   'False
      End
      Begin VB.Menu mnufile1 
         Caption         =   ""
         Index           =   502
         Visible         =   0   'False
      End
      Begin VB.Menu mnufile1 
         Caption         =   ""
         Index           =   503
         Visible         =   0   'False
      End
   End
End
Attribute VB_Name = "frmGeoSets"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'*****************************************************************************************************
'Declarations for various Windows functions for Registry Read/Write
'*****************************************************************************************************

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, _
ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, _
ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, ByVal lpData As String, lpcbData As Long) As Long

Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long

Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long

Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As _
String, ByVal cbData As Long) As Long

Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, _
ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, _
ByVal cbData As Long) As Long

'*****************************************************************************************************
'API  Constant Declarations
'*****************************************************************************************************
 
Const REG_SZ As Long = 1
Const REG_DWORD As Long = 4
 
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
 
Const ERROR_NONE = 0
Const ERROR_BADDB = 1
Const ERROR_BADKEY = 2
Const ERROR_CANTOPEN = 3
Const ERROR_CANTREAD = 4
Const ERROR_CANTWRITE = 5
Const ERROR_OUTOFMEMORY = 6
Const ERROR_INVALID_PARAMETER = 7
Const ERROR_ACCESS_DENIED = 8
Const ERROR_INVALID_PARAMETERS = 87
Const ERROR_NO_MORE_ITEMS = 259
 
Const KEY_ALL_ACCESS = &H3F
 
Const REG_OPTION_NON_VOLATILE = 0

'*****************************************************************************************************
'General variables
Dim mstrPathtoGSTs As String
Dim mstrLastUsedFile As String
'*****************************************************************************************************

 Private Function QueryValue(sKeyName As String, sValueName As String) As String
    
       Dim lRetVal As Long         'result of the API functions
       Dim hKey As Long            'handle of opened key
       Dim vValue As Variant      'setting of queried value
 
       lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = QueryValueEx(hKey, sValueName, vValue)
       QueryValue = vValue
       RegCloseKey (hKey)
 End Function
      
 
Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long
    Dim cch As Long
    Dim lrc As Long
    Dim lType As Long
    Dim lValue As Long
    Dim sValue As String
 
    On Error GoTo QueryValueExError
 
    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5
 
    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If
        ' For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue
        Case Else
            'all other data types not supported
            lrc = -1
    End Select
 
QueryValueExExit:
    QueryValueEx = lrc
    Exit Function
QueryValueExError:
    Resume QueryValueExExit
End Function

   
  Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long)
       Dim lRetVal As Long         'result of the SetValueEx function
       Dim hKey As Long             'handle of open key
 
       'open the specified key
       lRetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, sKeyName, 0, KEY_ALL_ACCESS, hKey)
       lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
       RegCloseKey (hKey)
   End Sub

Public Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
    Dim lValue As Long
    Dim sValue As String
    Select Case lType
        Case REG_SZ
            sValue = vValue
            SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
        Case REG_DWORD
            lValue = vValue
            SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
        End Select
End Function

Private Sub cmdCoordSys_Click()
'*****************************************************************************************************
    'Show the Coordinate Picker
    Map1.DisplayCoordSys.PickCoordSys
End Sub

Private Sub cmdLayerControl_Click()
'*****************************************************************************************************
    'Show Layer Control
    Map1.Layers.LayersDlg
End Sub

Private Sub Form_Load()
'*****************************************************************************************************
    Dim strTemp As String
    Dim intCounter As Integer
    Dim lngtemp As Long
    
     'Create the Registry Key for Most recently Used FileList if it doesn't exist
     RegCreateKeyEx HKEY_LOCAL_MACHINE, "SOFTWARE\MapInfo\GeosetManager", lngtemp, strTemp, lngtemp, lngtemp, lngtemp, lngtemp, lngtemp
    
    'Calling UpdateFileMenu will find the Most Recently Used file list and make menu choices for them
    Call UpdateFileMenu
    
    'Set the Tool Icons
    pctTools(1).Picture = ilstIcons.ListImages(4).Picture
    pctTools(2).Picture = ilstIcons.ListImages(2).Picture
    pctTools(3).Picture = ilstIcons.ListImages(3).Picture
    
    'Set the current tool
    Map1.CurrentTool = miZoomInTool
    
    'Set the icons for the File buttons
    pctFileIO(1).Picture = ilstIcons.ListImages(7).Picture
    pctFileIO(2).Picture = ilstIcons.ListImages(8).Picture
    pctFileIO(3).Picture = ilstIcons.ListImages(9).Picture
    
    'Get the location of the GST and map files
    strTemp = QueryValue("SOFTWARE\MapInfo\MapX\4.0", "GeoDictionary")
    
    'At this point strTemp looks something like this -> C:\Program Files\MapInfo\MapX\4.0\Maps\Geodict.dct
    'We just need the path
    
    'Search the string from right to elft
     For intCounter = Len(strTemp) To 1 Step -1
        'If we find a '\' then we have the path (all of the character to the left of it)
         If Mid$(strTemp, intCounter, 1) = "\" Then
            'Set the variable
            mstrPathtoGSTs = Left$(strTemp, intCounter)
            'Get out of the loop
            Exit For
         End If
      Next
      
     'Get the full path and filename of the current geoset
     mstrLastUsedFile = Map1.Geosets(Map1.Geoset).PathName
     
End Sub

Private Sub Form_Resize()
'*****************************************************************************************************
'This routine is called whenever the user resizes the main window.
Map1.Width = frmGeoSets.Width - fraMapViewTools.Left - fraMapViewTools.Width - 100
Map1.Height = frmGeoSets.Height - 100

End Sub

Private Sub mnuFile1_Click(Index As Integer)
'*****************************************************************************************************
'This is called any time the user chooses an item from the File
'
'The Index Numbers go a little something like this :