地图转换工具

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{E760686B-BC9E-4802-9ECF-175FDF4062CE}#5.0#0"; "MAPX50.DLL"
Begin VB.Form frmMain
   BackColor       =   &H0000C000&
   Caption         =   "Application Buddy"
   ClientHeight    =   11025
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   14295
   LinkTopic       =   "Form1"
   ScaleHeight     =   11025
   ScaleWidth      =   14295
   StartUpPosition =   3  '窗口缺省
   Begin VB.TextBox Text2
      Height          =   375
      Left            =   11640
      TabIndex        =   34
      Text            =   "33.75"
      Top             =   1920
      Width           =   1215
   End
   Begin VB.TextBox Text1
      Height          =   375
      Left            =   9960
      TabIndex        =   33
      Text            =   "101.25"
      Top             =   1920
      Width           =   1335
   End
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   3840
      Left            =   8520
      ScaleHeight     =   291.271
      ScaleMode       =   0  'User
      ScaleWidth      =   291.271
      TabIndex        =   32
      Top             =   2640
      Width           =   3840
   End
   Begin VB.CheckBox Check1
      BackColor       =   &H00FFC0C0&
      Caption         =   "启用"
      Height          =   375
      Left            =   11880
      TabIndex        =   31
      Top             =   1440
      Value           =   1  'Checked
      Width           =   1335
   End
   Begin VB.CommandButton Command3
      Caption         =   "Command3"
      Height          =   375
      Left            =   9480
      TabIndex        =   30
      Top             =   360
      Width           =   975
   End
   Begin VB.CommandButton Command1
      Caption         =   "保存图片"
      Height          =   375
      Left            =   10200
      TabIndex        =   29
      Top             =   960
      Width           =   1215
   End
   Begin VB.VScrollBar HScrolHeight
      Height          =   8000
      Left            =   8040
      Max             =   8000
      Min             =   10
      TabIndex        =   27
      Top             =   2400
      Value           =   4125
      Width           =   255
   End
   Begin VB.HScrollBar HScrolWidth
      Height          =   255
      Left            =   0
      Max             =   8000
      Min             =   10
      TabIndex        =   26
      Top             =   2040
      Value           =   10
      Width           =   8000
   End
   Begin VB.TextBox txminy
      Height          =   375
      Left            =   10200
      TabIndex        =   24
      Text            =   "31.241314"
      Top             =   1440
      Width           =   1455
   End
   Begin VB.TextBox txmaxy
      Height          =   375
      Left            =   8280
      TabIndex        =   23
      Text            =   "32.752846"
      Top             =   1440
      Width           =   1455
   End
   Begin VB.TextBox txmaxx
      Height          =   375
      Left            =   6480
      TabIndex        =   22
      Text            =   "107.773797"
      Top             =   1440
      Width           =   1455
   End
   Begin VB.TextBox txminx
      Height          =   375
      Left            =   4560
      TabIndex        =   21
      Text            =   "106.359066"
      Top             =   1440
      Width           =   1455
   End
   Begin VB.TextBox logTx
      Height          =   1335
      Left            =   8640
      MultiLine       =   -1  'True
      TabIndex        =   19
      Top             =   6720
      Width           =   4815
   End
   Begin VB.TextBox TextOutputDir
      Height          =   375
      Left            =   4800
      TabIndex        =   18
      Text            =   "J:/百度切图/TMPMAP"
      Top             =   360
      Width           =   1935
   End
   Begin VB.Frame Frame9
      BackColor       =   &H00FFC0C0&
      Caption         =   "输出位置"
      Height          =   735
      Left            =   4560
      TabIndex        =   16
      Top             =   120
      Width           =   3255
      Begin VB.CommandButton Command7
         Caption         =   "浏览"
         Height          =   375
         Left            =   2280
         TabIndex        =   17
         Top             =   240
         Width           =   855
      End
   End
   Begin VB.Frame Frame3
      BackColor       =   &H00FFC0C0&
      Caption         =   "输出级别  "
      Height          =   735
      Left            =   3360
      TabIndex        =   14
      Top             =   120
      Width           =   1095
      Begin VB.ComboBox Combo2
         Height          =   300
         ItemData        =   "frmMain.frx":0000
         Left            =   120
         List            =   "frmMain.frx":002B
         Style           =   2  'Dropdown List
         TabIndex        =   15
         Top             =   240
         Width           =   855
      End
   End
   Begin VB.Frame Frame7
      BackColor       =   &H00FFC0C0&
      Caption         =   "地图文件"
      Height          =   735
      Left            =   0
      TabIndex        =   11
      Top             =   120
      Width           =   3255
      Begin VB.TextBox TextMapFile
         Height          =   375
         Left            =   120
         Locked          =   -1  'True
         TabIndex        =   13
         Top             =   240
         Width           =   2055
      End
      Begin VB.CommandButton Command6
         Caption         =   "浏览"
         Height          =   375
         Left            =   2280
         TabIndex        =   12
         Top             =   240
         Width           =   855
      End
   End
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   1200
      Top             =   3720
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton Command17
      Caption         =   "go"
      Height          =   375
      Left            =   9240
      TabIndex        =   10
      Top             =   960
      Width           =   735
   End
   Begin VB.TextBox Text8
      Height          =   375
      Left            =   8160
      TabIndex        =   8
      Text            =   "333.3560229487"
      Top             =   960
      Width           =   975
   End
   Begin VB.TextBox Text7
      Height          =   375
      Left            =   6120
      TabIndex        =   7
      Top             =   960
      Width           =   975
   End
   Begin VB.TextBox Text6
      Height          =   375
      Left            =   4920
      TabIndex        =   6
      Top             =   960
      Width           =   975
   End
   Begin VB.CommandButton Command12
      Caption         =   "开始切片"
      Height          =   375
      Left            =   8160
      TabIndex        =   5
      Top             =   360
      Width           =   975
   End
   Begin VB.CommandButton Command10
      Caption         =   "全图"
      Height          =   375
      Left            =   3360
      TabIndex        =   4
      Top             =   960
      Width           =   735
   End
   Begin VB.CommandButton Command9
      Caption         =   "平移"
      Height          =   375
      Left            =   2280
      TabIndex        =   3
      Top             =   960
      Width           =   735
   End
   Begin VB.CommandButton Command8
      Caption         =   "缩小"
      Height          =   375
      Left            =   1200
      TabIndex        =   2
      Top             =   960
      Width           =   735
   End
   Begin VB.CommandButton Command5
      Caption         =   "放大"
      Height          =   375
      Left            =   120
      TabIndex        =   1
      Top             =   960
      Width           =   735
   End
   Begin MapXLib.Map MapMain
      Height          =   4125
      Left            =   120
      TabIndex        =   0
      Top             =   2400
      Width           =   3885
      _Version        =   500012
      _ExtentX        =   6853
      _ExtentY        =   7276
      _StockProps     =   1
      BackColor       =   -2147483633
      MapCatalog.GeoDictionary=   "GeoDictionary"
      GeoSet          =   "Empty GeosetName {9A9AC2F4-8375-44d1-BCEB-476AE986F190}"
      GeoSetUserName  =   "United States"
      LabelsAreEditable=   0   'False
      DefaultStyle.TextFontBackColor=   16777215
      DefaultStyle.SupportsBitmapSymbols=   -1  'True
      DefaultStyle.SymbolChar=   55
      DefaultStyle.SymbolFontBackColor=   16777215
      BeginProperty DefaultStyle.TextFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BeginProperty DefaultStyle.SymbolFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      DefaultStyle.LineStyle=   1
      DefaultStyle.LineWidth=   1
      DefaultStyle.RegionColor=   16777215
      DefaultStyle.LinePattern=   2
      DefaultStyle.RegionBackColor=   16777215
      DefaultStyle.RegionBorderStyle=   1
      DefaultStyle.RegionBorderWidth=   1
      Title.Visible   =   -1  'True
      Title.Text      =   "dddd"
      Title.Style.TextFontBackColor=   16777215
      Title.Style.TextFontOpaque=   -1  'True
      Title.Style.SymbolChar=   0
      BeginProperty Title.Style.TextFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "宋体"
         Size            =   23.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      BeginProperty Title.Style.SymbolFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "宋体"
         Size            =   23.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Title.X         =   1288
      Title.Y         =   240
      Map.NumericCoordSys.ProjectionInfo=   "frmMain.frx":0059
      Map.DisplayCoordSys.ProjectionInfo=   "frmMain.frx":0189
   End
   Begin VB.Label Label3
      BackColor       =   &H00FFC0C0&
      Caption         =   "Label3"
      Height          =   255
      Left            =   8280
      TabIndex        =   28
      Top             =   2040
      Width           =   1215
   End
   Begin VB.Label Label2
      BackColor       =   &H00FFC0C0&
      Caption         =   "Label2"
      Height          =   255
      Left            =   120
      TabIndex        =   25
      Top             =   1440
      Width           =   1935
   End
   Begin VB.Label Label1
      AutoSize        =   -1  'True
      BackColor       =   &H00FFC0C0&
      Caption         =   "盒子大小 左                    右                   上                   下"
      Height          =   180
      Left            =   3360
      TabIndex        =   20
      Top             =   1560
      Width           =   6750
   End
   Begin VB.Label Label8
      BackColor       =   &H00FFC0C0&
      Caption         =   "中心x            y              zoomlevel"
      Height          =   255
      Left            =   4440
      TabIndex        =   9
      Top             =   1080
      Width           =   4935
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'目前遗留问题
 
'5、地图mxd的修改与保存
'2、没有剩余时间提示
'4、服务、展示与工具的整合

Option Explicit

 Private Type SHITEMID
      cb             As Long
      abID         As Byte
  End Type
  Private Type ITEMIDLIST
      mkid         As SHITEMID
  End Type
  Const BIF_RETURNONLYFSDIRS = &H1
  Private Type BROWSEINFO
      hOwner                     As Long
      pidlRoot                 As Long
      pszDisplayName     As String
      lpszTitle               As String
      ulFlags                   As Long
      lpfn                         As Long
      lParam                     As Long
      iImage                     As Long
  End Type
  Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
 

  '上面为打开目录窗口的API说明
 
 
  Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
 
 
 
  Private Type PALETTEENTRY
   peRed As Byte
   peGreen As Byte
   peBlue As Byte
   peFlags As Byte
End Type

Private Type LOGPALETTE
   palVersion As Integer
   palNumEntries As Integer
   palPalEntry(255) As PALETTEENTRY
End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(7) As Byte
End Type

Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, _
        ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal _
        iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, _
        ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries _
        As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) _
        As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject _
        As Long) As Long
Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Long, ByVal XDest As _
        Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hDCSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop _
        As Long) As Long
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetForegroundWindow Lib "USER32" () As Long
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette _
        As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As _
        RECT) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As _
        Long) As Long
Private Declare Function GetDesktopWindow Lib "USER32" () As Long

Private Type PicBmp
   Size As Long
   type As Long
   hBmp As Long
   hPal As Long
   Reserved As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As _
        PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
 
 

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End Type
Private Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type

Public Enum GpStatus  'Status
    ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
End Enum
 
 
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As GpStatus
Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (imageattr As Long) As GpStatus
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, ByRef graphics As Long) As GpStatus
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As GpStatus
Private Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As GpStatus

 

Private Const scalePara = 2

Private Const c_tileSize = 256
Private m_currentTool As Integer

Private dbgCount As Integer
 
Private Sub Check1_Click()
  If Check1.Value = 0 Then
    txmaxx.Text = ""
    txmaxy.Text = ""
    txminx.Text = ""
    txminy.Text = ""
 
  End If
End Sub

Private Sub Combo2_Click()

    Me.MapMain.MapUnit = miUnitKilometer
   
    Me.MapMain.Width = 3502
    Me.MapMain.Height = 4125
       
    If Combo2.Text = 1 Then
        Text6.Text = "106.8750000000"
        Text7.Text = "28.1250000000"
        Text8.Text = "1130"
    End If
    If Combo2.Text = 2 Then
        Text6.Text = "104.0625000000"
        Text7.Text = "30.9375000000"
        Text8.Text = "550"
    End If
    If Combo2.Text = 3 Then
        Text6.Text = "102.6562500000"
        Text7.Text = "32.3437500000"
        Text8.Text = "270"
        '地图窗口大小
        'Me.MapMain.Width = 3578
        'Me.MapMain.Height = 4245
    End If
    If Combo2.Text = 4 Then
        Text6.Text = "101.9531250000"
        Text7.Text = "33.0468750000"
        'Text8.Text = "132"
       
        Text8.Text = "135"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
      
    End If
    If Combo2.Text = 5 Then
        Text6.Text = "101.6015625000"
        Text7.Text = "33.3984375000"
        Text8.Text = "68"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
    If Combo2.Text = 6 Then
        Text6.Text = "101.4257812500"
        Text7.Text = "33.5742187500"
        Text8.Text = "34"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
   
   
    If Combo2.Text = 7 Then
        Text6.Text = "101.3378906250"
        Text7.Text = "33.6621093750"
        Text8.Text = 34 / 2 & ""
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
    If Combo2.Text = 8 Then
        Text6.Text = "101.2939453125"
        Text7.Text = "33.7060546875"
        Text8.Text = 34 / 4 & ""
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
    If Combo2.Text = 9 Then
        Text6.Text = "101.2719726563"
        Text7.Text = "33.7280273438"
        Text8.Text = "4.4"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
    If Combo2.Text = 10 Then
        Text6.Text = "101.2609863281"
        Text7.Text = "33.7390136719"
        Text8.Text = "2.15"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
   
    If Combo2.Text = 11 Then
        Text6.Text = "101.2554931641"
        Text7.Text = "33.7445068359"
        Text8.Text = "1.075"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
   
    If Combo2.Text = 12 Then
        Text6.Text = "101.2527465820"
        Text7.Text = "33.7472534180"
        Text8.Text = "0.8"
        '地图窗口大小
        Me.MapMain.Width = 3502
        Me.MapMain.Height = 4125
        Me.MapMain.MapUnit = miUnitKilometer
    End If
   
   
End Sub

Private Sub Command1_Click()
    'Dim rectactive As RECT
    ' 得到窗口矩形
    'Dim r As Long
    'r = GetWindowRect(Image1.hWnd, rectactive)
    'If r = 0 Then MsgBox "创建抓图失败!"
    'savepix 0, 0, rectactive.Right - rectactive.Left, rectactive.Bottom - rectactive.Top, "J:/百度切图/TMPMAP/test.png"
   

End Sub

Private Sub Command10_Click()
    Set MapMain.Bounds = MapMain.Layers.Bounds
End Sub

Private Sub Command12_Click()
    dbgCount = 0
    Dim lev    '处理级别
    lev = Val(Combo2.Text)
    If lev < 1 Then
        MsgBox "请选择>=1级别!!"
        Exit Sub
    End If
   
    If Dir(TextOutputDir.Text, vbDirectory) = "" Then
        MsgBox "非法文件夹!"
    End If

   
    Dim tt As Date
   
    tt = Now()
   
   
    logTx.Text = "开始时间:" + FormatDateTime(tt) & Chr(13) & Chr(10)
   
    '保存文件的最小x与最小y
    Dim fx1 As Long, fx2 As Long, fy1 As Long, fy2 As Long
    '临时变量便利文件名
    Dim X As Long, Y As Long
    '保存间隔经纬度
    Dim divxy As Double
    '保存起始经纬度 startx starty
    Dim startx As Double, starty As Double
   
    Dim tmpx0 As Single, tmpy0 As Single, tmpx As Single, tmpy As Single, tmpsitx0 As Double, tmpsity0 As Double, tmpsitx As Double, tmpsity As Double
 
    startx = Text1.Text '101.25
    starty = Text2.Text '33.75
   
    ' 保存范围经纬度
    Dim minxdouble As Double, minydouble As Double, maxxdouble As Double, maxydouble As Double
    minxdouble = -999
    maxxdouble = 999
    minydouble = -999
    maxydouble = 999
   

   
   
    '以第一张图片的作为中心,本段认为已经将第一个坐标点定位精确
    Me.MapMain.ZoomTo Val(Text8.Text), Val(Text6.Text), Val(Text7.Text)
    Me.MapMain.Pan 0, 0
   
    sleeptime (lev - 1)
   
   
    Dim pix As Integer
       

  
    fx1 = (2 ^ (lev - 1)) * 25
    fy1 = (2 ^ (lev - 1)) * -17
    fx2 = (2 ^ (lev - 1)) * 26 - 1
    fy2 = (2 ^ (lev - 1)) * -16 - 1
   
    divxy = 11.25 / (2 ^ (lev - 1))
   
   
    If Len(Trim(txminx.Text)) <> 0 Then
        minxdouble = Val(txminx.Text)
        minxdouble = minxdouble - divxy
    End If
   
    If Len(Trim(txminy.Text)) <> 0 Then
        minydouble = Val(txminy.Text)
        minydouble = minydouble - divxy
    End If
   
    If Len(Trim(txmaxx.Text)) <> 0 Then
        maxxdouble = Val(txmaxx.Text)
        maxxdouble = maxxdouble + divxy
    End If
   
    If Len(Trim(txmaxy.Text)) <> 0 Then
        maxydouble = Val(txmaxy.Text)
        maxydouble = maxydouble + divxy
    End If
   
   
   
    '保存起始经纬度 startx starty
    Dim xmoveCount As Long, ymoveCount As Long
    Dim reSet As Boolean
    Dim markCount As Integer, allCount As Long, allSum As Long
    allSum = (2 ^ lev) * (2 ^ (lev - 2))
   
    markCount = 0
    ymoveCount = 0
    allCount = 0
   
    Dim iswait As Boolean
    iswait = False
   
    Dim startGetStop As Boolean
    Dim lastwait As Boolean
    startGetStop = False
    lastwait = True
   
    For Y = fy1 To fy2
        xmoveCount = 0
       
        If ((startGetStop = True) And (lastwait = False)) Then Exit For
       
        lastwait = False
        For X = fx1 To fx2
            '0查找图片左上角的像素
            tmpsitx0 = startx + (X - fx1) * divxy   '左上经纬度
            tmpsity0 = starty - (Y - fy1) * divxy   '左上经纬度
            MapMain.ConvertCoord tmpx0, tmpy0, tmpsitx0, tmpsity0, miMapToScreen

            '1查找图片右下点的像素  保存起始经纬度 startx starty
            ' 右下点的经纬度 (startx + x * divxy),(starty - y * divxy)
            tmpsitx = startx + (X - fx1 + 1) * divxy  '右下经纬度
            tmpsity = starty - (Y - fy1 + 1) * divxy  '右下经纬度
           
            MapMain.ConvertCoord tmpx, tmpy, tmpsitx, tmpsity, miMapToScreen
           
            '只要Y没有达到门限值就直接break
            If ((tmpsity0 > maxydouble) Or (tmpsity < minydouble)) Then
                markCount = markCount + fx2 - fx1
                allCount = allCount + fx2 - fx1
                Me.Caption = allCount & "/" & allSum & " " & tmpsity
                If allCount / 1000 = 0 Then
                  DoEvents
                End If
               
                Exit For
            End If
           
           ' If tmpsity < 32.59434 Then
                'Me.Caption = tmpsity
           ' End If
           
            If ((tmpsitx0 >= minxdouble) And (tmpsitx <= maxxdouble)) Then
              iswait = True
              DoEvents
              '2屏幕坐标从0,0 到右下点的像素进行切图保存
              savepix Round(tmpx0), Round(tmpy0), Round(tmpx) - Round(tmpx0), Round(tmpy) - Round(tmpy0), TextOutputDir.Text & "/" & lev & "_" & X & "_" & Y & ".png"
              startGetStop = True
              lastwait = True
             
            Else
              iswait = False
            End If
           
            '3地图从x平移到右下点像素+1像素 返回到1一直到地图边界
            xmoveCount = xmoveCount + Round(tmpx) - Round(tmpx0)
            MapMain.Pan Round(tmpx) - Round(tmpx0), 0
            sleeptime (iswait)
           
            markCount = markCount + 1
            allCount = allCount + 1
            Me.Caption = allCount & "/" & allSum & " " & tmpsity
           
            If allCount / 1000 = 0 Then
              DoEvents
            End If

        Next
       
        '记录每次需要向下移动的偏移
        ymoveCount = ymoveCount - (tmpy - 2)
       
        '10000张图片重置一次
        If markCount > 5000 Then
            reSet = True
            markCount = 0
        Else
            reSet = False
        End If
       
       
        '移动回去
      
       
        If reSet = True Then
           
            '重置地图
            MapMain.GeoSet = Me.TextMapFile
            MapMain.MapUnit = miUnitKilometer
            MapMain.TitleText = ""
            MapMain.ZoomTo Val(Text8.Text), Val(Text6.Text), Val(Text7.Text)
            MapMain.Pan 0, 0
            '重置后x已经对到原点,直接移动向下移动Y即可
            MapMain.Pan 0, ymoveCount
        Else
            '向下移动 x 为移动还原,并且向下移动y的距离
            'Me.MapMain.Pan -xmoveCount, -(tmpy - Round(tmpy0))
            Me.MapMain.Pan -xmoveCount, -(tmpy - 2)
        End If
       
        sleeptime (iswait)
    Next
   
    tt = Now() - tt
    logTx.Text = logTx.Text & "结束时间:" & FormatDateTime(Now()) & Chr(13) & Chr(10)
    logTx.Text = logTx.Text & "耗时" + FormatDateTime(tt)
   
End Sub

Private Sub printdebug(str As String)
    If dbgCount = 155 Then
        MsgBox "sss"
    End If
    dbgCount = dbgCount + 1
    Debug.Print str
End Sub

Private Sub sleeptime(iswait As Boolean)
    If iswait = True Then
        DoEvents
        DoEvents
        DoEvents
    End If
    ' DoEvents
    ' DoEvents
    ' DoEvents
   
End Sub

 

 

 

'抓窗口的图片
Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal _
    LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc _
    As Long) As Picture

    Dim hDCMemory As Long
    Dim hBmp As Long
    Dim hBmpPrev As Long
    Dim r As Long
    Dim hDCSrc As Long
    Dim hPal As Long
    Dim hPalPrev As Long
    Dim RasterCapsScrn As Long
    Dim HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long
    Dim LogPal As LOGPALETTE

    If Client Then
        hDCSrc = GetDC(hWndSrc)
    Else
        hDCSrc = GetWindowDC(hWndSrc)
    End If

    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    '获得屏幕属性
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)

    '如果屏幕对象有调色板则获得屏幕调色板
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        '建立屏幕调色板的拷贝
        LogPal.palVersion = &H300
        LogPal.palNumEntries = 256
        r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        '将新建立的调色板选如建立的内存绘图句柄中
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        r = RealizePalette(hDCMemory)
    End If

    '拷贝图象
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    '释放资源
    r = DeleteDC(hDCMemory)
    r = ReleaseDC(hWndSrc, hDCSrc)

    Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
  Dim r As Long

   Dim Pic As PicBmp
   Dim IPic As IPicture
   Dim IID_IDispatch As GUID

   '填充IDispatch界面
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With

   '填充Pic
   With Pic
      .Size = Len(Pic)          ' Pic结构长度
      .type = vbPicTypeBitmap   ' 图象类型
      .hBmp = hBmp              ' 位图句柄
      .hPal = hPal              ' 调色板句柄
   End With

   '建立Picture图象
   r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

   '返回Picture对象
   Set CreateBitmapPicture = IPic
End Function

 

Private Sub savepix(x1 As Integer, y1 As Integer, x2 As Integer, y2 As Integer, FileName As String)
    ' 得到窗口矩形
    ' 将返回一个picture对象                窗口句柄     false  0 ,0  矩形的右边- 矩形的左边 , 矩形的下边-矩形的上边
    Set Picture1.Picture = CaptureWindow(MapMain.hWnd, False, x1, y1, x2, y2)
   
    'Image1.
       
    SavePic Picture1, FileName, ".png"
End Sub

 

Public Sub CreatePath(strfilename As String)
    Dim strTemp As String, pathBefore As String, fullPath As String
    Dim pos As Integer, dLen As Integer
   
    strTemp = strfilename
    fullPath = ""
   
    pos = InStr(1, strTemp, "/")
    
    While (pos > 0)
   
        dLen = Len(strTemp)
        pathBefore = Left(strTemp, pos)
        fullPath = fullPath + Trim(pathBefore)
       
       
        If Dir(fullPath, vbDirectory) = "" Then
       
            MkDir fullPath
        End If
       
      
        strTemp = Right(strTemp, dLen - pos)
        pos = InStr(1, strTemp, "/")
        
    Wend
End Sub

    

 

'输出单个图片为png格式
Private Sub ExportMapToPng(outputName As String, x1 As Double, y1 As Double, x2 As Double, y2 As Double)
     Dim RECT As New MapXLib.Rectangle
 '设置地图边界矩形的正确方式
 RECT.Set x1, y1, x2, y2
 Set MapMain.Bounds = RECT

 
     MapMain.ExportMap outputName, miFormatPNG
    'MsgBox ("end")
End Sub

 

 

Private Sub Command17_Click()
    Dim lev As Integer, divxy2 As Double
    lev = Val(Combo2.Text)
    divxy2 = 11.25 / (2 ^ lev)

    'Text6.Text = Val(txminx.Text) + divxy2
    'Text7.Text = Val(txmaxy.Text) - divxy2
   
    Me.MapMain.ZoomTo Val(Text8.Text), Val(Text6.Text), Val(Text7.Text)
End Sub

 

 

Private Sub Command3_Click()
   'Me.MapMain.co
   MapMain.DisplayCoordSys.PickCoordSys
  
End Sub

 

Private Sub Command5_Click()
    MapMain.CurrentTool = miZoomInTool
End Sub

'打开地图文件
Private Sub Command6_Click()
    '打开一个gst文件作为当前地图
 
     
    
    On Error GoTo errhandler
    With CommonDialog1
       .CancelError = True
       .InitDir = App.Path '予设存档路径
       .Filter = "地图文件(*.GST) |*.GST| "
       .ShowOpen
    End With
    Me.TextMapFile = CommonDialog1.FileName
    MapMain.GeoSet = CommonDialog1.FileName
    MapMain.TitleText = ""
    Me.MapMain.MapUnit = miUnitKilometer
errhandler:
   Exit Sub
End Sub

Private Sub Command7_Click()
    SetOutputDir
End Sub

 

Private Sub Command8_Click()
    MapMain.CurrentTool = miZoomOutTool
End Sub

Private Sub Command9_Click()
    MapMain.CurrentTool = miPanTool
End Sub

Private Sub Form_Load()
 
 
  m_currentTool = 0
 
 HScrolHeight.Value = MapMain.Height
 HScrolWidth.Value = MapMain.Width
 Label3.Caption = MapMain.Height & "/" & MapMain.Width
End Sub

Private Sub Form_Unload(Cancel As Integer)
  'Clear variables
  'ToolbarControl1.SetBuddyControl Nothing
End Sub

 

Private Sub SetOutputDir()
     ' On Error Resume Next
        Dim bi     As BROWSEINFO
        Dim IDL     As ITEMIDLIST
        Dim r     As Long
        Dim pidl     As Long
        Dim tmpPath     As String
        Dim pos     As Integer
        bi.hOwner = Me.hWnd
        bi.pidlRoot = 0&
        bi.lpszTitle = "请选择路径：   "
        bi.ulFlags = BIF_RETURNONLYFSDIRS
        pidl = SHBrowseForFolder(bi)
        tmpPath = Space$(512)
        r = SHGetPathFromIDList(ByVal pidl, ByVal tmpPath)
        If r Then
              pos = InStr(tmpPath, Chr$(0))
              tmpPath = Left(tmpPath, pos - 1)
              Me.TextOutputDir.Text = ValidateDir(tmpPath)
        Else
              Me.TextOutputDir.Text = ""
        End If
  End Sub
  Private Function ValidateDir(tmpPath As String) As String
          If Right$(tmpPath, 1) = "/" Then
                  ValidateDir = Left(tmpPath, Len(tmpPath) - 1)
          Else
                  ValidateDir = tmpPath
          End If
  End Function

Private Sub TxtL1Num_Change()
    
    'TxtL1Num.Text = Round(Val(TxtL1Num.Text), 0)
    
End Sub

Private Sub TxtLvlNum_Change()
    Dim iLvlNum As Integer
    Dim i As Integer, j As Integer
   
   
    
    'TxtLvlNum.Text = Round(Val(TxtLvlNum), 0)
       
   ' iLvlNum = Val(TxtLvlNum)
    If iLvlNum < 1 Or iLvlNum > 30 Then
        Exit Sub
    End If
    Me.Combo2.Clear
   
   
    For i = 0 To iLvlNum - 1
        Me.Combo2.AddItem str(i), i
    Next i
    Me.Combo2.AddItem "全部"
    Me.Combo2.ListIndex = i
End Sub

 

'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    SavePic
'**    输    入 ：    pic(StdPicture)        -   图象句柄
'**             ：    FileName(String)       -   保存路径
'**             ：    Quality(Byte)          -   JPG图象质量
'**             ：    TIFF_ColorDepth(Long)  -   TTF格式的颜色深度
'**             ：    TIFF_Compression(Long) -   TTF格式的压缩比
'**    输    出 ：    无
'**    功能描述 ：    把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'**    日    期 ：
'**    修 改 人 ：    laviewpbt
'**    日    期 ：    2005-10-23 14.43.52
'**    版    本 ：    Version 1.2.1
'*************************************************************************
Private Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, picType As String, _
                    Optional ByVal Quality As Byte = 80, _
                    Optional ByVal TIFF_ColorDepth As Long = 24, _
                    Optional ByVal TIFF_Compression As Long = 6)
   Screen.MousePointer = vbHourglass
   Dim tSI As GdiplusStartupInput
   Dim lRes As Long
   Dim lGDIP As Long
   Dim lBitmap As Long
   Dim GDICopyBitmap As Long, GDIGraphics As Long, ImgAttr As Long
   Dim aEncParams() As Byte
   On Error GoTo ErrHandle:
   tSI.GdiplusVersion = 1   ' 初始化 GDI+
   lRes = GdiplusStartup(lGDIP, tSI)
   If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
      If lRes = 0 Then
         Dim tJpgEncoder As GUID
         Dim tParams As EncoderParameters    '初始化解码器的GUID标识
        
         Select Case picType
         Case ".jpg"
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            tParams.count = 1                               ' 设置解码器参数
            With tParams.Parameter ' Quality
               CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识
               .NumberOfValues = 1
               .type = 4
               .Value = VarPtr(Quality)
            End With
            ReDim aEncParams(1 To Len(tParams))
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
        Case ".png"
             CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".gif"
             CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".tiff"
             CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             tParams.count = 2
             ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
             With tParams.Parameter
                .NumberOfValues = 1
                .type = 4
                 CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID    ' 得到ColorDepth参数的GUID标识
                .Value = VarPtr(TIFF_Compression)
            End With
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
            With tParams.Parameter
                .NumberOfValues = 1
                .type = 4
                 CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID    ' 得到Compression参数的GUID标识
                .Value = VarPtr(TIFF_ColorDepth)
            End With
            Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
        Case ".bmp"                                               '可以提前写保存为BMP的代码，因为并没有用GDI+
            SavePicture pict, FileName
            Screen.MousePointer = vbDefault
            Exit Sub
        End Select
        GdipCreateBitmapFromScan0 256, 256, 0, &H21808, ByVal 0&, GDICopyBitmap
        'GdipCreateImageAttributes ImgAttr
        GdipGetImageGraphicsContext GDICopyBitmap, GDIGraphics
        GdipGraphicsClear GDIGraphics, &HFFFFFFFF
        GdipDrawImageRect GDIGraphics, lBitmap, 0, 0, 256, 256
        'GdipDisposeImageAttributes ImgAttr
         
         lRes = GdipSaveImageToFile(GDICopyBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像
         GdipDisposeImage lBitmap       ' 销毁GDI+图像
         GdipDisposeImage GDICopyBitmap
         GdipDeleteGraphics GDIGraphics
        
      End If
      GdiplusShutdown lGDIP              '销毁 GDI+
   End If
   Screen.MousePointer = vbDefault
   Erase aEncParams
   Exit Sub
ErrHandle:
    Screen.MousePointer = vbDefault
    MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号:  " & Err.Number & vbCrLf & "错误描述:  " & Err.Description, vbInformation Or vbOKOnly, "错误"
End Sub

 

 
Private Sub HScrolHeight_Change()
    MapMain.Height = HScrolHeight.Value
     Label3.Caption = MapMain.Height & "/" & MapMain.Width
End Sub

Private Sub HScrolWidth_Change()
    MapMain.Width = HScrolWidth.Value
     Label3.Caption = MapMain.Height & "/" & MapMain.Width
End Sub