' KMLからカシミール地名ファイル作成 ' Ver1.00 2011_09_30 kita.kouichi ' 問い合わせ等:kita.kouichi@pref.hokkaido.lg.jp 'QGISで作成したポイントデータのKMLファイルを 'カシミール3Dの地名ファイルに変換します Option Explicit '参考にしたURL:http://www.happy2-island.com/vbs/cafe02/capter00205.shtml '定数の宣言 Const ForReading = 1 '読み込み Const ForWriting = 2 '書きこみ(上書きモード) Const ForAppending = 8 '書きこみ(追記モード) Dim txt_Read MsgBox ("KMLファイルをカシミール3Dの地名ファイルに変換します。") 'パラメタ情報の保存 Set txt_Read = WScript.Arguments '取得したパラメタが1コ未満のときはエラー If txt_Read.Count < 1 Then WScript.Echo "ファイルが少ないです。1つだけドロップしてください。" '取得したパラメタが1コより多いときもエラー ElseIf txt_Read.Count > 1 Then WScript.Echo "ファイルが多いです。1つだけドロップしてください。" Else '取得したパラメタが1コのときはOKなので 'テキストファイルの読み込み処理へ飛ばす Call prcTextFileRead '←(A) End If 'オブジェクト破棄 Set txt_Read = Nothing 'これ以降はCallなどで呼び出さない限り実行しない。 '============================================================= '以降はテキストファイル読み込みのプロシジャ '上の(A)から呼び出される '============================================================= Sub prcTextFileRead() Dim objFileSys Dim objInFile Dim objOutFile ' Dim intSep ' Dim strScriptPath Dim txt_Read_Name Dim strFilePath Dim strRecord Dim txt_New_Name Dim txt_data Dim d_Field Dim d_meishou Dim d_ido, d_ido_do, d_ido_fun1, d_ido_fun2, d_ido_byou, d_ido_byou1, d_ido_byou2 Dim d_keido, d_kei_do, d_kei_fun1, d_kei_fun2, d_kei_byou, d_kei_byou1, d_kei_byou2 Dim lngpoint Dim lngPos1, lngPos2, lngPos3 Dim objRE Dim d_count Dim d_meiOK Dim d_Level, d_youzar Dim level_CD, youzar_ID 'パラメタを保存(ファイル名として使用) txt_Read_Name = txt_Read(0) 'IEで簡易プロレスバーを作成する。参考URL:http://www.whitire.com/vbs/tips0169.html Dim lngLoop, lngLoop_count, lngLoop_Max ' ループカウンタ Dim objIE ' IE オブジェクト Set objIE = CreateObject("InternetExplorer.Application") If Err.Number = 0 Then objIE.Width = 180 objIE.Height = 70 objIE.AddressBar = False objIE.MenuBar = False objIE.Toolbar = False objIE.Resizable = False objIE.Visible = True End If lngLoop = 0 objIE.StatusText = "ファイル読み込み中・・・" 'UTF-8のKMLファイルを読み込むため、ADODB.Streamに変更 '入力ストリームの生成・設定(テキスト、UTF-8) Set objInFile = CreateObject("ADODB.Stream") objInFile.Type = 2 '1:バイナリデータ 2:テキストデータ objInFile.Charset = "UTF-8" '入力ファイルの文字コード設定 objInFile.Open objInFile.LoadFromFile txt_Read_Name '入力ファイルを読み込む '改行コードを変更する strRecord = objInFile.ReadText strRecord = Replace(strRecord, vbLf, vbCrLf) objInFile.WriteText strRecord '改行コードを変換したものを書き込む objInFile.SaveToFile txt_Read_Name & ".tx1",2 '仮のファイルで保存(既にある場合は上書き) objInFile.Close '改めてファイルを読み込み objInFile.Type = 2 '1:バイナリデータ 2:テキストデータ objInFile.Charset = "UTF-8" '入力ファイルの文字コード設定 objInFile.Open objInFile.LoadFromFile txt_Read_Name & ".tx1" '仮のファイルを読み込む '出力ストリームの生成・設定(テキスト、UTF-8) Set objOutFile = CreateObject("ADODB.Stream") objOutFile.Type = 2 objOutFile.Charset = "Shift-JIS" '出力ファイルの文字コード設定 objOutFile.Open 'ファイルのオープンが成功(ファイル有り)のときはErr.Numberが0 If Err.Number = 0 Then '新しい地名ファイルのフルパスを設定(元のファイルと同じファイル名で、拡張子が.ndb) txt_New_Name = Left(txt_Read_Name, Len(txt_Read_Name) - 4) & ".ndb" 'ファイルシステムオブジェクトの作成 Set objFileSys = CreateObject("Scripting.FileSystemObject") '地名ファイルを同じフォルダに作成 objFileSys.CreateTextFile txt_New_Name '地名にするフィールド名をインプットボックスで入力します。 d_Field = InputBox("地名にするデータのフィールド名を入力してください。") '作成する地名ファイルの地名属性を設定します。 d_youzar = InputBox("作成する地名の種類(ユーザー1〜5)を半角数字1〜5で入力してください。") Select Case d_youzar Case "1" youzar_ID = "101" Case "2" youzar_ID = "102" Case "3" youzar_ID = "103" Case "4" youzar_ID = "104" Case "5" youzar_ID = "105" Case Else MsgBox ("入力された内容が認識できません。ユーザー1で作成します。") youzar_ID = "101" End Select '作成する地名ファイルのレベルを設定します。 d_Level = InputBox("作成する地名のレイヤレベルを半角数字1〜5で入力してください。" & vbCrLf & "上に表示したいものほどレベルを上げます。") Select Case d_Level Case "1" level_CD = 1 Case "2" level_CD = 11 Case "3" level_CD = 21 Case "4" level_CD = 31 Case "5" level_CD = 41 Case Else MsgBox ("入力された内容が認識できません。レベル2で作成します。") level_CD = 11 End Select '地名やレイヤの情報を書き込み objOutFile.WriteText ";KASHMIRNDB", 1 objOutFile.WriteText "MeshSize=-1", 1 objOutFile.WriteText ";!!Landmark ID=""" & youzar_ID & """ Font=""-11,700,0,128,49,0,MS ゴシック,1,16777215"" Icon=""903001"" Flag=""1"" User=""" & d_Field & """", 1 objOutFile.WriteText ";!!Layer ID=""1"" Name=""レベル1""", 1 objOutFile.WriteText ";!!Layer ID=""11"" Name=""レベル2""", 1 objOutFile.WriteText ";!!Layer ID=""21"" Name=""レベル3""", 1 objOutFile.WriteText ";!!Layer ID=""31"" Name=""レベル4""", 1 objOutFile.WriteText ";!!Layer ID=""41"" Name=""レベル5""", 1 objOutFile.WriteText ";", 1 d_count = 0 d_meiOK = False objIE.StatusText = "行数計測中・・・" 'テキストファイルの行数をカウント 参考URL:http://oshiete.goo.ne.jp/qa/3530672.html Dim FSO Dim myLine Set FSO = CreateObject("Scripting.FileSystemObject") With FSO.GetFile(txt_Read_Name).OpenAsTextStream(8) myLine = .Line .Close End With Set FSO = Nothing lngLoop_Max = myLine lngLoop_count = 100 / lngLoop_Max '入力ファイルから一行ずつ読み出して、出力ストリームへ書き出す Do While objInFile.EOS = False strRecord = objInFile.ReadText(-2) 'ReadTextの第一引数:-1:全部読み込む -2:一行読み込む '名称を検索し取得します。 '正規表現を定義します Set objRE = CreateObject("VBScript.RegExp") 'objRE.Pattern = "^.*.*$" 'データのある行の場合には、データを取り出す If objRE.Test(strRecord) Then lngPos1 = InStr(1, strRecord, ">", 0) lngPos2 = InStr(lngPos1, strRecord, "<", 0) d_meishou = Mid(strRecord, lngPos1 + 1, lngPos2 - lngPos1 - 1) d_count = d_count + 1 d_meiOK = True End If If d_meiOK = True Then '緯度経度を検索し取得します。 '正規表現を定義します Set objRE = CreateObject("VBScript.RegExp") objRE.Pattern = "^.*.*$" If objRE.Test(strRecord) Then '経度を取り出す lngPos1 = InStr(1, strRecord, "s>", 0) lngPos2 = InStr(lngPos1, strRecord, ",", 0) d_keido = Mid(strRecord, lngPos1 + 2, 10) d_kei_do = Int(d_keido) d_kei_fun1 = 60 * (d_keido - d_kei_do) d_kei_fun2 = Int(d_kei_fun1) If Len(d_kei_fun2) = 1 Then d_kei_fun2 = "0" & d_kei_fun2 '1桁の場合は2桁に修正 End If d_kei_byou = 60 * (d_kei_fun1 - d_kei_fun2) lngpoint = InStr(1, d_kei_byou, ".", 0) If lngpoint = 0 Then d_kei_byou1 = "00" d_kei_byou2 = "00" Else d_kei_byou1 = Left(d_kei_byou, lngpoint - 1) If Len(d_kei_byou1) = 1 Then d_kei_byou1 = "0" & d_kei_byou1 '1桁の場合は2桁に修正 End If d_kei_byou2 = Mid(d_kei_byou, lngpoint + 1, 2) If Len(d_kei_byou2) = 1 Then d_kei_byou2 = "0" & d_kei_byou2 '1桁の場合は2桁に修正 End If End If d_keido = d_kei_do & "." & d_kei_fun2 & d_kei_byou1 & d_kei_byou2 '緯度を取り出す lngPos3 = InStr(lngPos2, strRecord, "<", 0) d_ido = Mid(strRecord, lngPos2 + 1, 9) d_ido_do = Int(d_ido) d_ido_fun1 = 60 * (d_ido - d_ido_do) d_ido_fun2 = Int(d_ido_fun1) If Len(d_ido_fun2) = 1 Then d_ido_fun2 = "0" & d_ido_fun2 '1桁の場合は2桁に修正 End If d_ido_byou = 60 * (d_ido_fun1 - d_ido_fun2) lngpoint = InStr(1, d_ido_byou, ".", 0) If lngpoint = 0 Then d_ido_byou1 = "00" d_ido_byou2 = "00" Else d_ido_byou1 = Left(d_ido_byou, lngpoint - 1) If Len(d_ido_byou1) = 1 Then d_ido_byou1 = "0" & d_ido_byou1 '1桁の場合は2桁に修正 End If d_ido_byou2 = Mid(d_ido_byou, lngpoint + 1, 2) If Len(d_ido_byou2) = 1 Then d_ido_byou2 = "0" & d_ido_byou2 '1桁の場合は2桁に修正 End If End If d_ido = d_ido_do & "." & d_ido_fun2 & d_ido_byou1 & d_ido_byou2 'テキストファイルへの書き込み(1行書き込み) objOutFile.WriteText d_meishou & " " & d_ido & " " & d_keido & " 0.0 _ A " & level_CD & " " & youzar_ID & " 1 WGS84", 1 'フラグをfalseに戻す d_meiOK = False End If End If objIE.StatusText = "行数:" & lngLoop & " / " & lngLoop_Max lngLoop = lngLoop + 1 Loop objIE.Quit If d_count = 0 Then MsgBox ("変換したデータは0件でした。フィールド名が間違っていませんか?") End If MsgBox ("処理は終了しました。") 'ファイルのオープンが失敗(ファイル無し)のときはErr.Numberが0以外 Else WScript.Echo txt_Read_Name & "がありませんでした。" End If '出力ファイル生成 objOutFile.SaveToFile txt_New_Name, 2 '1:ファイルがない場合はファイル作成 2:ファイルがある場合は上書き 'ファイルシステムオブジェクトを作成し、一時保存ファイルの削除 'オブジェクト作成 Set FSO = CreateObject("Scripting.FileSystemObject") FSO.DeleteFile txt_Read_Name & ".tx1" Set FSO = Nothing 'ストリームを閉じる objInFile.Close objOutFile.Close 'オブジェクトを解放 Set objInFile = Nothing Set objInFile = Nothing Set objFileSys = Nothing Set objRE = Nothing Set objIE = Nothing End Sub