Sub 図形､線2()  '図形や線を描いてみる 

'http://www5a.biglobe.ne.jp/~kkw_pl2/kkwvbs/vbabitmap.htm 

    Dim MyStrFile As String

    Dim MyDC0, MyDC1 As Long

    Dim MyBMP As Long

    Dim MyPen As Long

    Dim MyBrush As Long

    Dim MyBMPInf As BITMAPINFO

    Dim MyBMPFLHdr As BITMAPFILEHEADER

    Dim MyBMPBits() As Byte

    Dim MyFNUM As Long

    

   MyStrFile = CurrentProject.path & "\tmp00.bmp" 'Accessの場合 



    MyDC0 = GetDC(0&)

    MyDC1 = CreateCompatibleDC(MyDC0)

    With MyBMPInf.bmiHeader

        .biSize = 40

        .biWidth = CWIDTH

        .biHeight = CHEIGHT

        .biPlanes = 1

        .biBitCount = 24

    End With

    MyBMP = CreateDIBSection(MyDC1, MyBMPInf, 0, 0, 0, 0)

    Call SelectObject(MyDC1, MyBMP)

    

    MyPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255))

    Call SelectObject(MyDC1, MyPen)

    MyBrush = GetStockObject(WHITE_BRUSH)

    Call SelectObject(MyDC1, MyBrush)

    Call Rectangle(MyDC1, 0, 0, CWIDTH, CHEIGHT)

    Call DeleteObject(MyPen)

    Call DeleteObject(MyBrush)

    

 Dim f1 As Double

 Dim f2 As Double

 Dim rs As Recordset

 Dim db As DAO.Database

Dim Sql As String

Dim path As String

Dim ppath As String

Dim pre As Long

Dim i As Long

pre = 1



'https://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi 

ppath =  街区のcsvを置いたフォルダ

path = ppath & Right("00" & pre, 2) & "000-19.0a\" & Right("00" & pre, 2) & "000-19.0a"

Set db = OpenDatabase(path, False, False, "Text;DATABASE=" & path)

Sql = "SELECT * FROM [" & Right("00" & pre, 2) & "_2020.csv] WHERE (緯度 Is Not Null) ORDER BY 緯度"

Set rs = db.OpenRecordset(Sql, dbOpenDynaset)

'https://kajimublog.com/memo-dao-csv-insert/ 



 rs.MoveFirst

 i = 1

 Do Until rs.EOF

f1 = (50 - rs!緯度) / 30 * 1500

f2 = (rs!経度 - 120) / 30 * 1500

i = i + 1

    If i Mod 200 = 0 Then

     MyPen = CreatePen(PS_SOLID, 2, RGB(255, 0, 0))

    Call SelectObject(MyDC1, MyPen)

    Call Rectangle(MyDC1, f2, f1, f2 + 3, f1 + 3)

    Call DeleteObject(MyPen)

    Else

    End If

 rs.MoveNext

 Loop

 rs.Close

 Set rs = Nothing

     

    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0&, MyBMPInf, 0)

    ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)

    Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)

    MyFNUM = FreeFile

    Open MyStrFile For Binary As #MyFNUM

    With MyBMPFLHdr

        .bfType = "BM"

        .bfReserved1 = 0

        .bfReserved2 = 0

        .bfSize = Len(MyBMPFLHdr) + Len(MyBMPInf) + UBound(MyBMPBits) + 1

        .bfOffBits = Len(MyBMPFLHdr) + Len(MyBMPInf)

    End With

    Put #MyFNUM, , MyBMPFLHdr

    Put #MyFNUM, , MyBMPInf

    Put #MyFNUM, , MyBMPBits

    Close #MyFNUM



    Call DeleteObject(MyBMP)

    Call DeleteObject(MyDC1)

    Call ReleaseDC(0&, MyDC0)

    

End Sub