鄉(xiāng)鎮(zhèn)鎮(zhèn)谷歌地圖怎么做MAPINFOW文件？     

使用方法：

1、需安裝版google，打開google選擇所需區(qū)域截圖保存為JPG格式

2、在Excel中自建一個(gè)workbook，ALT+F11進(jìn)入VBA界面，新建一個(gè)模塊，將代碼拷貝進(jìn)去。
代碼如下：

Option Explicit

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Type BITMAP

    bmType As Long

    bmWidth As Long

    bmHeight As Long

    bmWidthBytes As Long

    bmPlanes As Integer

    bmBitsPixel As Integer

    bmBits As Long

End Type

Private Type PicInfo

    PicWidth As Long

    picHeight As Long

End Type

Private Function GetPicSize(lsPicName As String) As PicInfo

    Dim hBitmap As Long

    Dim res As Long

    Dim picHdl As Variant

    Dim bmp As BITMAP

    res = GetObject(LoadPicture(lsPicName).Handle, Len(bmp), bmp)      '取得BITMAP的結(jié)構(gòu)

    GetPicSize.PicWidth = bmp.bmWidth

    GetPicSize.picHeight = bmp.bmHeight

    'DeleteObject picHdl

End Function

Sub GoogleEarth_COMAPI_GenRasterMap()

    Dim gei As Object

    Dim gec As Object

    Dim gep As Object

    Dim picW As Integer

    Dim picH As Integer

    Dim sFileName As String

    Dim vTmp As Variant

    On Error Resume Next

    Set gei = CreateObject("GoogleEarth.ApplicationGE")

    If Err.Number > 0 Then

        MsgBox "連接GoogleEarth失敗！"

        Exit Sub

    End If

    sFileName = Application.GetSaveAsFilename("", "*.jpg,*.jpg")

    Set gec = gei.GetCamera(0)

    gec.Tilt = 0

    gec.Azimuth = 0

    If gec.Range > 100000 Then

        MsgBox "范圍過大，將自動調(diào)整為100km！"

        gec.Range = 100000

    End If

    gei.SetCamera gec, 10

    gei.SaveScreenShot sFileName, 100

    Dim picS As PicInfo

    picS = GetPicSize(sFileName)

    'Dim pic As StdPicture

    'Set pic = StdFunctions.LoadPicture(sFileName)

    'picW = pic.Width

    'picH = pic.Height

    'Set pic = Nothing

    Dim iFNo As Integer

    iFNo = FreeFile()

    Open Left(sFileName, Len(sFileName) - 3) & "tab" For Output As #iFNo

    Print #iFNo, "!Table"

    Print #iFNo, "!version 300"

    Print #iFNo, "!charset WindowsSimpChinese"

    Print #iFNo, ""

    Print #iFNo, "Definition Table"

    vTmp = Split(sFileName, "")

    Print #iFNo, "  File """ & vTmp(UBound(vTmp)) & """"

    Print #iFNo, "  Type ""RASTER"""

    Set gep = gei.GetPointOnTerrainFromScreenCoords(-1, 1)

    Print #iFNo, "  (" & gep.Longitude & "," & gep.Latitude & ") (0,0) Label ""Pt 1"","

    Set gep = gei.GetPointOnTerrainFromScreenCoords(1, 1)

    Print #iFNo, "  (" & gep.Longitude & "," & gep.Latitude & ") (" & picS.PicWidth - 1 & ",0) Label ""Pt 2"","

    Set gep = gei.GetPointOnTerrainFromScreenCoords(-1, -1)

    Print #iFNo, "  (" & gep.Longitude & "," & gep.Latitude & ") (0" & "," & picS.picHeight - 1 & ") Label ""Pt 3"","

    Set gep = gei.GetPointOnTerrainFromScreenCoords(1, -1)

    Print #iFNo, "  (" & gep.Longitude & "," & gep.Latitude & ") (" & picS.PicWidth - 1 & "," & picS.picHeight - 1 & ") Label ""Pt 4"""

    Print #iFNo, "  CoordSys Earth Projection 1, 104"

    Print #iFNo, "  Units ""Degree"""

    Close #iFNo

    Set gei = Nothing

    Set gec = Nothing

    Set gep = Nothing

    MsgBox "OK, refer to " & sFileName

End Sub

感谢您访问我们的网站，您可能还对以下资源感兴趣：