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

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

 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 = "C:\Users\Y2\Desktop\API64\tmp00e.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)

 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

 

 hPenPrev = SelectObject(MyDC1, hPen)

 hBrPrev = SelectObject(MyDC1, hBr)

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

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

 

 For pre = 1 To 3

    Debug.Print pre & "-" & Now()

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

    

    ppath = "C:\Users\Y2\Desktop\API64\"

    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/ 

 

     Do Until rs.EOF

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

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

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

      rs.MoveNext

     Loop

     

    rs.Close

    Set rs = Nothing

    Set db = Nothing

    Debug.Print pre & "-" & "-" & Now()

    SelectObject MyDC1, hPenPrev

    SelectObject MyDC1, hBrPrev

    DeleteObject hPen

    DeleteObject hBr

 Next

 

 Const NullPtr As LongPtr = 0

 GetDIBits MyDC1, MyBMP, 0, CHEIGHT, ByVal NullPtr, MyBMPInf, 0

 ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)

 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

 

 DeleteObject MyBMP

 DeleteObject MyDC1

 ReleaseDC 0, MyDC0

 End Sub