【Word VBA】福井県地図描画マクロ▽ソースコード

Option Explicit

Option Base 0

'

Public Sub 福井県地図描画マクロ()

    '地理データファイル名

    Const MAPDATFN = "N03-11A-2K_18.txt"

    '

    '国土数値情報ダウンロードサイトより

    '

    'TOP> 国土数値情報>行政界・海岸線データ

    '「N03-11A-18-01.0a.zip」を解凍するとある。

    'それを、この文書ファイルと同じフォルダーに置く。

    '

    'なお、(18）は福井県で、他の都道府県の場合は、

    'その番号が違う。

    '

    Const MAPDTMAX = 20000　　      '最大データ数

    Const MAPDRATE = 250　　　       '描画倍率

    '

    Const MAPDLEFT = 80　　　　       '描画左上位置(X)

    Const MAPDTOPP = 70 　　　　　　'　　           (Y)

    '

    Const MAPDLNCL = 9109504　　　'線の色(紺)

    '---------------------------------------------------------------------------

    Dim Ip As Integer, Jp As Integer, Kp As Integer

    Dim Lp As Long, Mp As Long, Np As Long

    Dim strFna As String, strRec As String

    Dim lngPDt(MAPDTMAX, 1) As Long, lngPDp As Long

    Dim lngPWk(1) As Long

    Dim lngMin(1) As Long, lngMax(1) As Long

    Dim lngLmt(1) As Long, sngPos() As Single

    '

    strFna = ActiveDocument.Path & "\" & MAPDATFN

    If Dir(strFna) = "" Then

       MsgBox "Not Found File": Exit Sub

    End If

    '

    'データファイルオープン

    Open strFna For Input As #1

    '

    lngPDp = 0

    Do While Not EOF(1)

       Line Input #1, strRec　　                    'ファイル読み込み

       If Left(strRec & " ", 1) = "L" Then 　　 'ラインデータ？

          Lp = Val(Right("000" & strRec, 3))

          If Lp > 0 Then

             For Ip = 0 To Lp - 1 Step 5

                 If EOF(1) Then Exit For

                 Line Input #1, strRec                'ファイル読み込み

                 strRec = strRec & Space(64)

                 For Jp = 0 To 4

                     lngPWk(0) = Val(Mid(strRec, Jp * 16 + 1, 8))

                     lngPWk(1) = Val(Mid(strRec, Jp * 16 + 9, 8))

                     If lngPWk(0) > 0 And lngPWk(0) > 0 Then

                        'データ取り出し＆最大・最小取得

                        For Kp = 0 To 1

                            lngPDt(lngPDp, Kp) = lngPWk(Kp)

                            If lngPDp = 0 Then

                               lngMin(Kp) = lngPWk(Kp)

                               lngMax(Kp) = lngPWk(Kp)

                            Else

                               If lngMin(Kp) > lngPWk(Kp) Then _

                                  lngMin(Kp) = lngPWk(Kp)

                               If lngMax(Kp) < lngPWk(Kp) Then _

                                  lngMax(Kp) = lngPWk(Kp)

                            End If

                        Next Kp

                        lngPDp = lngPDp + 1

                     End If

                 Next Jp

             Next Ip

             'データ区切り

             lngPDt(lngPDp, 0) = -1: lngPDp = lngPDp + 1

          End If

       End If

    Loop

'

    '範囲把握

    lngLmt(0) = lngMax(0) - lngMin(0)

    lngLmt(1) = lngMax(1) - lngMin(1)

    '

    Lp = 0

    Do While Lp < lngPDp - 1

       DoEvents                         '←時間がかかるので挿入

       Mp = Lp

       Do While Lp < lngPDp - 1

          If lngPDt(Lp, 0) > 0 Then Lp = Lp + 1 Else Exit Do

       Loop

       Np = Lp - Mp: If Np <= 0 Then Exit Do Else Lp = Lp + 1

       '行政界・海岸線(ポリライン)作成

       ReDim sngPos(Np - 1, 1)

       For Kp = 0 To Np - 1

           sngPos(Kp, 0) = _

           ((lngPDt(Mp + Kp, 0) - lngMin(0)) / lngLmt(0)) _

                         * MAPDRATE + MAPDLEFT

           sngPos(Kp, 1) = _

           (1 - ((lngPDt(Mp + Kp, 1) - lngMin(1)) / lngLmt(1))) _

                         * MAPDRATE + MAPDTOPP

       Next Kp

       '行政界・海岸線(ポリライン)を描画

       With ActiveDocument.Shapes.AddPolyline(sngPos)

                .Fill.Visible = msoFalse

                .Line.Visible = msoTrue

                .Line.ForeColor = MAPDLNCL           '←線色

       End With

   Loop

    'データファイルクローズ

    Close #1

End Sub

《蛇足》

　国土数値情報の行政界・海岸線データの最新は、平成１１年のもので、行政界が市町村合併する前のものになっています。