VERSION 5.00Object = "{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 EndEndAttribute VB_Name = "frmMain"Attribute VB_GlobalNameSpace = FalseAttribute VB_Creatable = FalseAttribute VB_PredeclaredId = TrueAttribute 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 ByteEnd Type
Private Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRYEnd Type
Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As ByteEnd Type
Private Const RASTERCAPS As Long = 38Private Const RC_PALETTE As Long = &H100Private Const SIZEPALETTE As Long = 104
Private Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd Type
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Long) As LongPrivate Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Long, _ ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Long, ByVal _ iCapabilitiy As Long) As LongPrivate Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Long, _ ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries _ As PALETTEENTRY) As LongPrivate Declare Function CreatePalette Lib "GDI32" (lpLogPalette As LOGPALETTE) _ As LongPrivate Declare Function SelectObject Lib "GDI32" (ByVal hDC As Long, ByVal hObject _ As Long) As LongPrivate 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 LongPrivate Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Long) As LongPrivate Declare Function GetForegroundWindow Lib "USER32" () As LongPrivate Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Long, ByVal hPalette _ As Long, ByVal bForceBackground As Long) As LongPrivate Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Long) As LongPrivate Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Long) As LongPrivate Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As LongPrivate Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As _ RECT) As LongPrivate Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hDC As _ Long) As LongPrivate Declare Function GetDesktopWindow Lib "USER32" () As Long
Private Type PicBmp Size As Long type As Long hBmp As Long hPal As Long Reserved As LongEnd 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 LongEnd TypePrivate Type EncoderParameter GUID As GUID NumberOfValues As Long type As Long Value As LongEnd TypePrivate Type EncoderParameters count As Long Parameter As EncoderParameterEnd 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 = 20End Enum Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatusPrivate Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As GpStatusPrivate Declare Function GdipCreateImageAttributes Lib "gdiplus" (imageattr As Long) As GpStatusPrivate Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, ByRef graphics As Long) As GpStatusPrivate 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 GpStatusPrivate 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 GpStatusPrivate Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As LongPrivate Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As LongPrivate Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hPal As Long, bitmap As Long) As LongPrivate Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As LongPrivate Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As LongPrivate Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As LongPrivate Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As LongPrivate Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As GpStatus
Private Const scalePara = 2
Private Const c_tileSize = 256Private 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 IfEnd 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.BoundsEnd 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 strEnd 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 = IPicEnd 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, "/") WendEnd 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 = miZoomInToolEnd 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 = miUnitKilometererrhandler: Exit SubEnd Sub
Private Sub Command7_Click() SetOutputDirEnd Sub
Private Sub Command8_Click() MapMain.CurrentTool = miZoomOutToolEnd Sub
Private Sub Command9_Click() MapMain.CurrentTool = miPanToolEnd Sub
Private Sub Form_Load() m_currentTool = 0 HScrolHeight.Value = MapMain.Height HScrolWidth.Value = MapMain.Width Label3.Caption = MapMain.Height & "/" & MapMain.WidthEnd Sub
Private Sub Form_Unload(Cancel As Integer) 'Clear variables 'ToolbarControl1.SetBuddyControl NothingEnd 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 = iEnd 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 SubErrHandle: 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.WidthEnd Sub
Private Sub HScrolWidth_Change() MapMain.Width = HScrolWidth.Value Label3.Caption = MapMain.Height & "/" & MapMain.WidthEnd Sub
