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

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

 Dim a As String

 a = Now()

    Dim MyStrFile As String

    Dim MyDC0 As LongPtr

    Dim MyDC1 As LongPtr

    Dim MyBMP As LongPtr

    Dim MyPen As LongPtr

    Dim MyBrush As LongPtr

    Dim MyPenPrev As LongPtr

    Dim MyBrushPrev As LongPtr

    Dim hPen As LongPtr

    Dim hBr As LongPtr

    Dim hPenPrev As LongPtr

    Dim hBrPrev As LongPtr

    

    

    Dim MyBMPInf As BITMAPINFO

    Dim MyBMPFLHdr As BITMAPFILEHEADER

    Dim MyBMPBits() As Byte

    Dim MyFNUM As Long

    

   MyStrFile = "街区データを置いたフォルダ\"& \tmp00d.bmp" 

 

    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)

    SelectObject MyDC1, MyBMP

    

    ' ペンとブラシを選択 



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

    MyBrush = GetStockObject(WHITE_BRUSH)

    MyPenPrev = SelectObject(MyDC1, MyPen)

    MyBrushPrev = SelectObject(MyDC1, MyBrush)

    Rectangle MyDC1, 0, 0, CWIDTH, CHEIGHT

    SelectObject MyDC1, MyPenPrev

    SelectObject MyDC1, MyBrushPrev

    

 Dim f1 As Double

 Dim f2 As Double

 Dim rs As DAO.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



 For pre = 1 To 3

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

ppath = "街区データを置いたフォルダ\"

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, dbOpenForwardOnly, dbReadOnly)

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



        hPen = CreatePen(PS_SOLID, 1, RGB(255, 0, 0))

        hBr = CreateSolidBrush(RGB(255, 0, 0))

 i = 1

 Do Until rs.EOF

f1 = (50 - rs!緯度) / 20 * 15000

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

i = i + 1

        hPenPrev = SelectObject(MyDC1, hPen)

        hBrPrev = SelectObject(MyDC1, hBr)

        Rectangle MyDC1, f2, f1, f2 + 3, f1 + 3

        SelectObject MyDC1, hPenPrev

        SelectObject MyDC1, hBrPrev

 rs.MoveNext

 Loop

 rs.Close

 Set rs = Nothing

 Set db = Nothing

 Next

        DeleteObject hPen

        DeleteObject hBr



    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)

    MsgBox a & "-" & Now()

End Sub