Option Explicit 'Grid size of GTOPO30 Public Const GRID_SIZE_ORG = 8.33333333333333E-03 Const LACK = -9999 Const UPPER_LIMIT = 10000 'values over this is regarded as invalid '////////////////////////////////////////////////////////// ' ' function declaration for tar32.dll ' ' You have to insatll TAR32.DLL from ' http://www.openlab.jp/tsuneo/tar32/index-e.html ' Const FNAME_MAX32 = 512 Const FNAME_MAX32PLUS1 = FNAME_MAX32 + 1 ' Info. on each stored file Private Type tagINDIVIDUALINFO dwOriginalSize As Long ' /* File size (original) */ dwCompressedSize As Long ' /* File size (compressed) */ dwCRC As Long ' /* Check Sum (CRC) */ uFlag As Long ' /* Result Code */ uOSType As Long ' /* OS used for compression */ wRatio As Integer ' /* Compression ratio */ wDate As Integer ' /* DateStamp(DOS Format) */ wTime As Integer ' /* TimeStamp(ditto) */ szFilename As String * FNAME_MAX32PLUS1 ' /* Archive File Name */ dummy1 As String * 3 szAttribute As String * 8 ' /* Attribute of original File */ szMode As String * 8 ' /* Mode of stored file */ End Type 'From tar32api.h of source file of tar32.dll '#ifndef FNAME_MAX32 '#define FNAME_MAX32 512 '#End If 'typedef struct { ' DWORD dwOriginalSize; ' DWORD dwCompressedSize; ' DWORD dwCRC; ' UINT uFlag; ' UINT uOSType; ' WORD wRatio; ' WORD wDate; ' WORD wTime; ' char szFileName[FNAME_MAX32 + 1]; ' char dummy1[3]; ' char szAttribute[8]; ' char szMode[8]; '} INDIVIDUALINFO; Private Declare Function TarOpenArchive Lib "tar32.DLL" _ (ByVal hWnd As Long, _ ByVal szFilename As String, _ ByVal dwMode As Long) As Long Private Declare Function TarCloseArchive Lib "tar32.DLL" _ (ByVal harc As Long) As Long Private Declare Function TarFindFirst Lib "tar32.DLL" _ (ByVal harc As Long, _ ByVal szWildName As String, _ lpSubInfo As tagINDIVIDUALINFO) As Long Private Declare Function TarFindNext Lib "tar32.DLL" _ (ByVal harc As Long, _ lpSubInfo As tagINDIVIDUALINFO) As Long Private Declare Function Tar Lib "tar32.DLL" _ (ByVal lHWnd As Long, _ ByVal szCmdLine As String, _ ByVal szOutput As String, _ ByVal lSize As Long) As Long Declare Function TarSetOwnerWindow Lib "Tar32" (ByVal hWnd As Long) As Long '////////////////////////////////////////////////////////// '// '// Other Functions declarations Declare Function GetActiveWindow Lib "USER32" () As Long Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" ( _ ByVal TempPathSize As Long, _ ByVal TempPath As String) As Long '////////////////////////////////////////////////////////// '// '// Worksheet Format for *.asc -type worksheet '// '// '// Const COL_HEADER_ITEM = 1 Const COL_HEADER = COL_HEADER_ITEM + 1 Const ROW_NCOLS = 1 Const ROW_NROWS = 2 Const ROW_XLLCORNER = 3 Const ROW_YLLCORNER = 4 Const ROW_CELLSIZE = 5 Const ROW_NODATA_VALUE = 6 Const ROW_START = 8 Const COL_START = 2 '////////////////////////////////////////////////////////// '// '// '// '// '// ' ' convert(average) GTOPO (*.DEM) data to specified grid size ' Sub GTOPOconv(strDemFileName As String, fLat_Top As Double, fLon_Left As Double, _ iNCols As Integer, iNRows As Integer, _ fGrid_Size_Target As Double, fResult() As Double) Dim u As Long Dim b1 As Byte, b2 As Byte Dim iX As Integer, iY As Integer Dim iX_Org As Integer, iY_Org As Integer Dim lPos As Long Dim fSum As Double, iCount As Integer Dim iFN As Integer Const SEA = 55537 Dim fLat As Double, fLon As Double Dim fY_Grid_Ratio As Double, fX_Grid_Ratio As Double Dim fXY_Grid_Ratio As Double Dim iY_From As Integer, iY_To As Integer Dim iX_From As Integer, iX_To As Integer Dim iY_From_Org As Integer, iX_From_org As Integer Dim iY_To_Org As Integer, iX_To_Org As Integer Dim fLat_Bottom As Double, fLon_Right As Double Dim fGrid_Size_Org As Double Dim fX_Grid_Size_Org As Double, fY_Grid_Size_Org As Double Dim fX_Grid_Size_Target As Double, fY_Grid_Size_Target As Double Dim fLat_Height_Org As Double, fLon_Width_Org As Double Dim iX_Size_Org As Integer, iY_Size_Org As Integer Dim iX_Size_Target As Integer, iY_Size_Target As Integer '============================================================= ' ' Range of Original DEM ' fX_Grid_Size_Org = GRID_SIZE_ORG fY_Grid_Size_Org = GRID_SIZE_ORG fX_Grid_Size_Target = fGrid_Size_Target fY_Grid_Size_Target = fGrid_Size_Target fLon_Right = fLon_Left + fX_Grid_Size_Org * iNCols fLat_Bottom = fLat_Top - fY_Grid_Size_Org * iNRows '============================================================= fLat_Height_Org = fLat_Top - fLat_Bottom fLon_Width_Org = fLon_Right - fLon_Left iX_Size_Org = fLon_Width_Org / fX_Grid_Size_Org iY_Size_Org = fLat_Height_Org / fY_Grid_Size_Org fX_Grid_Ratio = fX_Grid_Size_Target / fX_Grid_Size_Org fY_Grid_Ratio = fY_Grid_Size_Target / fY_Grid_Size_Org fXY_Grid_Ratio = fX_Grid_Ratio * fY_Grid_Ratio iX_Size_Target = fLon_Width_Org / fX_Grid_Size_Target iY_Size_Target = fLat_Height_Org / fY_Grid_Size_Target ' Set Array ReDim fResult(iY_Size_Target, iX_Size_Target) 'File Opening iFN = FreeFile() On Error GoTo 0 Open strDemFileName For Binary As #iFN Len = 1 lPos = 1 ' ' ' 'Set wshResult = Worksheets("Result") 'wshResult.Cells.ClearContents iY_From = 1 '(LAT_TOP_ORG - LAT_TOP) / Y_GRID_SIZE + 1 iY_To = iY_Size_Target '(LAT_TOP_ORG - LAT_BOTTOM) / Y_GRID_SIZE iX_From = 1 '(LON_LEFT - LON_LEFT_ORG) / X_GRID_SIZE + 1 iX_To = iX_Size_Target '(LON_RIGHT - LON_LEFT_ORG) / X_GRID_SIZE 'If iX_From < 1 Then iX_From = 1 'If iX_to > iX_Size_Org / fX_Grid_Ratio Then iX_to = iX_Size_Org / fX_Grid_Ratio 'Read Loop! For iY = iY_From To iY_To iY_From_Org = (iY - 1) * (fY_Grid_Ratio) + 1 iY_To_Org = iY * (fY_Grid_Ratio) For iX = iX_From To iX_To iX_From_org = (iX - 1) * (fX_Grid_Ratio) + 1 iX_To_Org = iX * (fX_Grid_Ratio) ' ' loop for original cells ' fSum = 0# iCount = 0 For iY_Org = iY_From_Org To iY_To_Org For iX_Org = iX_From_org To iX_To_Org 'lPos : location of the original value in the original file lPos = ((iX_Org - 1) + 1& * (iY_Org - 1) * (iX_Size_Org)) * 2 + 1 'Reading big-endian value Get #iFN, lPos, b1 Get #iFN, lPos + 1, b2 u = b1 * 256& + b2 'Summing Up If u > LACK And u < UPPER_LIMIT Then fSum = fSum + 1# * u iCount = iCount + 1 End If Next Next ' ' statistics ' If iCount > 0 Then Debug.Print iY; " : "; iX, iCount; fSum / fXY_Grid_Ratio fResult(iY - iY_From + 1, iX - iX_From + 1) = fSum / fXY_Grid_Ratio Else Debug.Print iY; " : "; iX, iCount; "LACK" fResult(iY - iY_From + 1, iX - iX_From + 1) = LACK End If DoEvents Application.StatusBar = "File : " & strDemFileName & _ " progress=" & iY & " / " & iY_Size_Target Next Next Close #iFN End Sub ' '[private] GTOPOstore : store result data (in fResult) into a Worksheet ' in forms of *.asc file ' Private Sub GTOPOstore(strWorksheetName As String, fLat_Top As Double, fLon_Left As Double, _ iNCols As Integer, iNRows As Integer, _ fGrid_Size As Double, fResult() As Double) Dim wshResult As Worksheet Dim fLon_Right As Double, fLat_Bottom As Double Dim iY_From As Integer, iY_To As Integer Dim iX_From As Integer, iX_To As Integer Dim iY As Integer, iX As Integer Dim fR As Double Dim fLat As Double, fLon As Double 'Prepare the worksheet On Error Resume Next Worksheets(strWorksheetName).Activate If Err <> 0 Then Worksheets.Add.Select ActiveSheet.Name = strWorksheetName End If On Error GoTo 0 Set wshResult = ActiveSheet wshResult.Cells.ClearContents 'Var. set fLon_Right = fLon_Left + fGrid_Size * iNCols fLat_Bottom = fLat_Top - fGrid_Size * iNRows iY_From = 1 iY_To = iNRows iX_From = 1 iX_To = iNCols ' ' Write Lat/Lon ' For iY = 1 To iNRows fLat = fLat_Top - (iY - 1) * fGrid_Size - 0.5 * fGrid_Size wshResult.Cells(iY - 1 + ROW_START, COL_START - 1).Value = fLat Next For iX = 1 To iNCols fLon = fLon_Left + (iX - 1) * fGrid_Size + 0.5 * fGrid_Size If fLon >= 360 Then fLon = fLon - 360 'ElseIf fLon < 0 Then ' fLon = fLon + 360 End If wshResult.Cells(ROW_START - 1, iX - 1 + COL_START).Value = fLon Next ' 'Write Each Value ' For iY = 1 To iNRows For iX = 1 To iNCols ' ' each cell ' If fResult(iY, iX) <> LACK Then wshResult.Cells(iY - 1 + ROW_START, iX - 1 + COL_START).Value = fResult(iY, iX) End If DoEvents Next Application.StatusBar = "Storing " & strWorksheetName & " : " & iY & " / " & iNRows Next ' ' Header ' With wshResult .Cells(ROW_NCOLS, COL_HEADER_ITEM).Value = "ncols" .Cells(ROW_NCOLS, COL_HEADER).Value = iNCols .Cells(ROW_NROWS, COL_HEADER_ITEM).Value = "nrows" .Cells(ROW_NROWS, COL_HEADER).Value = iNRows .Cells(ROW_XLLCORNER, COL_HEADER_ITEM).Value = "xllcorner" .Cells(ROW_XLLCORNER, COL_HEADER).Value = fLon_Left .Cells(ROW_YLLCORNER, COL_HEADER_ITEM).Value = "yllcorner" .Cells(ROW_YLLCORNER, COL_HEADER).Value = fLat_Top - fGrid_Size * iNRows .Cells(ROW_CELLSIZE, COL_HEADER_ITEM).Value = "cellsize" .Cells(ROW_CELLSIZE, COL_HEADER).Value = fGrid_Size .Cells(ROW_NODATA_VALUE, COL_HEADER_ITEM).Value = "nodata_value" .Cells(ROW_NODATA_VALUE, COL_HEADER).Value = LACK End With ' ' Format ' With wshResult .Activate ActiveWindow.FreezePanes = False .Cells(ROW_START, COL_START).Select ActiveWindow.FreezePanes = True .Range(.Cells(ROW_START, COL_START), .Cells(ROW_START + iNRows - 1, _ COL_START + iNCols - 1)).Select Selection.NumberFormat = "0.0" End With ' ' FreezePane ' wshResult.Activate ActiveWindow.FreezePanes = False wshResult.Cells(ROW_START, COL_START).Select ActiveWindow.FreezePanes = True End Sub ' '[Private]GTOPOconvnstore : GTOPOconv + GTOPOstore. Temporary array for storing ' result is prepared here. ' Sub GTOPOconvstore(strFileName As String, strSheetName As String, fLon_Left As Double, fLat_Top As Double, _ iNCols As Integer, iNRows As Integer, _ fGrid_Size As Double) Dim fResult() As Double Dim fGrid_Size_Ratio As Double fGrid_Size_Ratio = fGrid_Size / GRID_SIZE_ORG Call GTOPOconv(strFileName, fLat_Top, fLon_Left, iNCols, iNRows, fGrid_Size, fResult) Call GTOPOstore(strSheetName, fLat_Top, fLon_Left, _ iNCols / fGrid_Size_Ratio, iNRows / fGrid_Size_Ratio, fGrid_Size, fResult) End Sub ' '[Public]conv : Convert *.DEM in all *.tar.gz (GTOPO30 original files) to ' arbitrary grid size (average) ' Public Sub conv_main() 'Change this line as you like Const GRID_SIZE_TARGET_DEFAULT = 0.5 Dim varFile As Variant Dim strCWD As String, strFileName As String, strSheetName As String Dim strDemFile As String Dim strTempDir As String Dim strBuffer As String * FNAME_MAX32PLUS1 Dim fLat_Top As Double, fLon_Left As Double Dim iNCols As Integer, iNRows As Integer Dim fLon_Sign As Double, fLat_Sign As Double Dim fGrid_Size_Target As Double Dim iPos As Integer Dim strTemp As String Dim i As Integer 'Directory Settings Call GetTempPath(Len(strBuffer), strBuffer) iPos = InStr(strBuffer, vbNullChar) If iPos > 0 Then strTempDir = Left$(strBuffer, iPos - 1) Else strTempDir = ".\" End If 'Target grid size fGrid_Size_Target = Val( _ InputBox("Target Grid Size? (default=" & GRID_SIZE_TARGET_DEFAULT & ")", _ "Grid Size", _ GRID_SIZE_TARGET_DEFAULT) _ ) If fGrid_Size_Target <= 0 Then Exit Sub varFile = Application.GetOpenFilename( _ FileFilter:= _ "compressed GTOPO30 DEM File(*.tar.gz),*.tar.gz, " & _ "All Files(*.*),*.*", _ Title:="Select Directory ") If varFile <> False Then strCWD = CurDir() strFileName = Dir$(strCWD & "\" & "*.tar.gz", vbNormal & vbReadOnly) Do While Len(strFileName) > 0 'Lon/Lat info. iPos = InStrRev(strFileName, "\") 'File name : such as "W120S60.DEM.gz" strTemp = UCase(Mid$(strFileName, iPos + 1, 1)) If strTemp = "E" Then fLon_Sign = 1 Else fLon_Sign = -1 fLon_Left = Val(Mid$(strFileName, iPos + 2, 3)) * fLon_Sign strTemp = UCase(Mid$(strFileName, iPos + 5, 1)) If strTemp = "N" Then fLat_Sign = 1 Else fLat_Sign = -1 fLat_Top = Val(Mid$(strFileName, iPos + 6, 2)) * fLat_Sign If fLat_Top <> 0 And fLon_Left <> 0 Then 'Caution : this is acutally not right condition 'Matrix Size : normally 6000*4800. But for "S60" files,3600*7200 If fLat_Top <> -60 Then iNCols = 4800 iNRows = 6000 Else iNCols = 7200 iNRows = 3600 End If 'SheetName strSheetName = Mid$(strFileName, iPos + 1, 7) strSheetName = UCase(strSheetName) 'gunzip Application.StatusBar = "extracting " & strFileName strDemFile = Tar_Extract_OneFile(strFileName, "*.DEM", strTempDir) If Len(strDemFile) > 0 Then 'Process Application.StatusBar = "Proccessing : " & strFileName 'Debug.Print "Files : " & strFileName; "/"; strSheetName Debug.Print "Temp. File=" & strDemFile Call GTOPOconvstore(strDemFile, strSheetName, _ fLon_Left, fLat_Top, iNCols, iNRows, fGrid_Size_Target) 'Delete extracted file Kill strDemFile End If End If 'valid file name? 'To the next file strFileName = Dir$() Loop ChDir (strCWD) Application.StatusBar = False Debug.Print "Finish" End If End Sub Private Function Tar_Extract_OneFile(strArcFileName As String, strTargetFileWild As String, _ strDirName As String) As String Dim udtINDIVIDUALINFO As tagINDIVIDUALINFO Dim strFileName As String Dim lArcHandle As Long ' Dim lResult As Long ' Dim lHWnd As Long Dim strCommand As String Dim strSwitch As String Dim strCommandLine As String Dim strBuffer As String * 1024 Dim iPos As Integer Tar_Extract_OneFile = "" ' Open archive file lHWnd = GetActiveWindow lArcHandle = TarOpenArchive(lHWnd, strArcFileName, 0) If lArcHandle <> 0 Then ' Search target file udtINDIVIDUALINFO.szFilename = String$(Len(udtINDIVIDUALINFO.szFilename), " ") If TarFindFirst(lArcHandle, strTargetFileWild, udtINDIVIDUALINFO) = 0 Then iPos = InStr(udtINDIVIDUALINFO.szFilename, vbNullChar) If iPos > 0 Then strFileName = Left$(udtINDIVIDUALINFO.szFilename, iPos - 1) Debug.Print strFileName ' do not search next... 'lResult = TarFindNext(lArcHandle, udtINDIVIDUALINFO) lResult = TarCloseArchive(lArcHandle) Debug.Print "Closed" 'Extraction 'end of strDirName must be "\" strDirName = Trim(strDirName) If Len(strDirName) = 0 Then strDirName = ".\" Else If Right$(strDirName, 1) <> "\" Then strDirName = strDirName & "\" End If End If strCommand = "-xzf" 'Extract strSwitch = "" '"-jp1" 'Show progress bar strCommandLine = Trim( _ strCommand & " " & _ strSwitch & " " & _ """" & strArcFileName & """ " & _ "-o " & """" & strDirName & """ " & _ strFileName _ ) lHWnd = GetActiveWindow lResult = Tar(lHWnd, _ strCommandLine, _ strBuffer, _ Len(strBuffer) - 1) ' Close If lResult = 0 Then Tar_Extract_OneFile = strDirName & strFileName End If End If End If End Function ' '[Public]make_asc_file : Making global *.asc file from worksheets which were ' made by conv_main(). ' Public Sub make_asc_file() Dim wshResult As Worksheet 'Worksheet Dim strSheetName As String 'Worksheet Name Dim rngCell As Range 'Cell in operation Dim fGrid_Size As Double 'Grid Size (common) Dim fGrid_Size_This As Double 'Grid Size (read from worksheet) Dim iX_Result_Size As Integer Dim iY_Result_Size As Integer 'Size of fResult() (Global Grid Matrix) Dim fResult() As Double 'Array for result. Top_left is (180W, 90N) Const GLOBAL_LON_LEFT = -180 Const GLOBAL_LAT_TOP = 90 Dim fR As Double 'Temporary Dim iFN As Integer 'File # Dim fLon As Double Dim fLat As Double Dim fXllCorner As Double Dim fYllCorner As Double 'XLLCORNER/YLLCORNER in worksheet Dim fLack As Double 'NODATA_VALUE in worksheet Dim iNRows As Integer Dim iNCols As Integer 'NCOLS/NROWS in worksheet Dim iX As Integer Dim iY As Integer 'Loop Counter Dim iX_Base As Integer Dim iY_Base As Integer '"Original Point" of data field in each worksheet ' on fResult() Dim strTemp As String 'Temporary Dim strTemp2 As String Dim varFileName As Variant 'Variable for GetSaveAsFileName Dim strFileName As String 'File Name (*.asc) Dim strFormat As String 'Number Format Const FORMAT_DEFAULT = "0.0" Const EPS = 0.00001 'Small value (for int()) fGrid_Size = -1 iFN = -1 ' ' Loop for worksheets ' Valid Sheet Name is GTOPO30-form, such as "E020N40" For Each wshResult In Worksheets strSheetName = Trim(UCase(wshResult.Name)) fLon = Val(Mid$(strSheetName, 2, 3)) fLat = Val(Mid$(strSheetName, 6, 2)) strTemp = Left$(strSheetName, 1) strTemp2 = Mid$(strSheetName, 5, 1) If fLon <> 0 And fLat <> 0 And (strTemp = "E" Or strTemp = "W") And _ (strTemp2 = "S" Or strTemp2 = "N") Then ' ' Choose File / Format (First loop only) ' If iFN < 0 Then varFileName = Application.GetSaveAsFilename( _ "GlobDem", _ "ESRI ASC File (*.asc),*.asc" _ ) If varFileName = False Then Exit Sub strFileName = CStr(varFileName) iFN = FreeFile() strFormat = InputBox( _ "Number Format? (Default=" & FORMAT_DEFAULT & ")", _ "Format String", _ FORMAT_DEFAULT) If Len(strFormat) = 0 Then Exit Sub End If ' ' Process each sheet ' Application.StatusBar = "processing : " & wshResult.Name Debug.Print wshResult.Name ' ' Get Sheet Info (and Check) ' With wshResult 'Grid Size(Cellsize) fGrid_Size_This = .Cells(ROW_CELLSIZE, COL_HEADER).Value If fGrid_Size > 0 Then If fGrid_Size <> fGrid_Size_This Then MsgBox ("Fatal Error : Sheet " & strSheetName & " : " & _ "Grid Size (" & fGrid_Size_This & ")is different from others " & _ "(" & fGrid_Size & ")") Exit Sub End If Else fGrid_Size = fGrid_Size_This ' ' Initialize ' iX_Result_Size = Int(360# / fGrid_Size + EPS) iY_Result_Size = Int(180 / fGrid_Size + EPS) ReDim fResult(iY_Result_Size, iX_Result_Size) For iY = 1 To iY_Result_Size For iX = 1 To iX_Result_Size fResult(iY, iX) = LACK Next Next End If 'Lat/Lon fXllCorner = .Cells(ROW_XLLCORNER, COL_HEADER).Value fYllCorner = .Cells(ROW_YLLCORNER, COL_HEADER).Value 'Topleft of result array is (180W, 90N) If fXllCorner >= 180 Then fXllCorner = fXllCorner - 360 'Size iNRows = .Cells(ROW_NROWS, COL_HEADER).Value iNCols = .Cells(ROW_NCOLS, COL_HEADER).Value 'nodata_value fLack = .Cells(ROW_NODATA_VALUE, COL_HEADER).Value If iNRows <= 0 Or iNCols <= 0 Then MsgBox ("Fatal Error : Illegal Value : nrows=" & iNRows & ", " & _ "ncols=" & iNCols) Exit Sub End If 'TODO : consistent with sheet name? 'TODO : fLack consistency '(base (x,y) in fResult(). 1 origin) iX_Base = (fXllCorner - GLOBAL_LON_LEFT) / fGrid_Size + 1 iY_Base = (GLOBAL_LAT_TOP - (fYllCorner + fGrid_Size * iNRows)) / fGrid_Size + 1 End With ' ' Loop ' With wshResult For iX = 1 To iNCols For iY = 1 To iNRows Set rngCell = .Cells(iY + ROW_START - 1, iX + COL_START - 1) If Len(rngCell.Text) > 0 Then fR = rngCell.Value Else fR = fLack End If fResult(iY_Base + iY - 1, iX_Base + iX - 1) = fR Next iY Next iX End With End If 'Valid sheet? Next ' ' File Output ' If iFN > 0 Then Open strFileName For Output As #iFN 'Header Print #iFN, "ncols "; iX_Result_Size Print #iFN, "nrows "; iY_Result_Size Print #iFN, "xllcorner "; fXllCorner Print #iFN, "yllcorner "; fYllCorner Print #iFN, "cellsize "; fGrid_Size Print #iFN, "nodata_value "; fLack End If For iY = 1 To iY_Result_Size Application.StatusBar = "Writing " & strFileName & " : " & iY & " / " & iY_Result_Size Debug.Print "Writing " & strFileName & " : " & iY & " / " & iY_Result_Size For iX = 1 To iX_Result_Size fR = fResult(iY, iX) If fR <> fLack Then Print #iFN, Format$(fR, strFormat); " "; Else Print #iFN, Format$(fR, "0"); " "; End If Next Print #iFN, Next ' ' Finish ' Close #iFN Application.StatusBar = False End Sub