bitmapに沢山追加したいです

タグの編集
投稿者 snowmansnow  (社会人) 投稿日時 2021/12/28 20:03:23

 こんばんは、国土交通省の街区csvデータをbitmapに描画しようとしました。
 'https://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi
 'http://www5a.biglobe.ne.jp/~kkw_pl2/kkwvbs/vbabitmap.htmを参考に作ってみました。
 でも、約3000件程度を上限に、bitmapに描画できないエラーになりました。
 1都道府県約30万件、47都道府県約1400万件を描画してみたいです。

 
Option Explicit
Private Type BITMAPFILEHEADER
       bfType       As String * 2
       bfSize       As Long
       bfReserved1  As Integer
       bfReserved2  As Integer
       bfOffBits    As Long
End Type

Private Type BitmapInfoHeader
    biSize  As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BitmapInfoHeader
End Type

Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongAs Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongAs Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pbmi As BITMAPINFO, _
                                                    ByVal iUsage As LongByVal ppvBits As Long, _
                                                    ByVal hSection As LongByVal dwOffset As LongAs Long
Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongByVal hBitmap As Long, _
                                                ByVal nStartScan As LongByVal nNumScans As Long, _
                                                lpBits As Any, lpBI As BITMAPINFO, _
                                                ByVal wUsage As LongAs Long
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongByVal hgdiobj As LongAs Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongAs Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongByVal hdc As LongAs Long
Private Declare PtrSafe Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle As LongByVal nWidth As Long, _
                                                    ByVal crColor As LongAs Integer
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As LongAs Long
Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As Long, _
                                                ByVal X1 As LongByVal Y1 As Long, _
                                                ByVal X2 As LongByVal Y2 As LongAs Long

Private Const PS_SOLID = 0
Private Const WHITE_BRUSH = 0
Private Const GRAY_BRUSH = 2
Private Const CWIDTH = 1500
Private Const CHEIGHT = 1500
投稿者 snowmansnow  (社会人) 投稿日時 2021/12/28 20:05:39
 また長いので追加です
 
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, FalseFalse"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

 よろしくお願いします。
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2021/12/28 21:44:34
VBA7 な Access VBA が前提のようですが、API 宣言が結構間違っていませんか?
LongPtr にすべきところが Long になってたり、
Any に対して Win32/Win64 判定の無いまま  「ByVal 0&」 が無条件に渡されていたり…。


> 約3000件程度を上限に、bitmapに描画できないエラーになりました。
コードは斜め読みしただけでまだ試していないため、
どこでどういうエラーが出たのか分かりませんし、
描画エラーの要因も掴んではいませんが、ひとまず気になったところから。


> 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)
MyDC1 で選択中のペンオブジェクトを削除してはまずいのではないでしょうか。
処分前に、最初のオブジェクトに復元しておいた方がよろしいかと。
https://ja.stackoverflow.com/questions/33072/


> Dim MyDC0, MyDC1 As Long
VBA の文法だと、上記は
 Dim MyDC0 As [既定の型]  ' 初期設定では As Variant 相当
 Dim MyDC1 As Long
の意味になってしまいます。両方を Long にしたいのであれば
 Dim MyDC0&, MyDC1 As Long
または
 Dim MyDC0 As Long, MyDC1 As Long
と書きます。ただし本来は LongPtr とすべきですね。


> Private Const PS_SOLID = 0
これも As Long を付けるべきです。
動作に影響は無いものの、現状だと「Integer 型」の定数あるいは
「内部処理形式が 整数型(Integer) な値を持った Variant 型」の定数になってしまいそう。


> Dim rs As Recordset
> Dim db As DAO.Database
As ADODB.Recordset と混同しないためにも
As DAO.Recordset にした方が良いですね。

> Set rs = db.OpenRecordset(Sql, dbOpenDynaset)
> rs.MoveFirst
> Do Until rs.EOF
MoveFirst が明示的に呼ばれていますね。

処理系によっては、意図的に MoveFirst が必要になる場合もありますが
(oo4o で ORADYN_NO_MOVEFIRST フラグが立っている場合など)、
DAO の Text I-ISAM では関係無いような…。

自分ならここは
 Set rs = db.OpenRecordset(Sql, dbOpenForwardOnly, dbReadOnly)
 Do Until rs.EOF
にしますね。編集するわけでも無いので、カーソルも前方参照モードを選択。
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2021/12/28 21:47:33
そもそも、ループ中で何度も MyPen を作り直している理由が分からない…。
投稿者 snowmansnow  (社会人) 投稿日時 2021/12/28 22:53:26

 こんばんは、魔界の仮面弁士様
 >VBA7 な Access VBA が前提のようですが、API 宣言が結構間違っていませんか?
  ごめんなさい、見直しました
 
 Option Explicit
Private Type BITMAPFILEHEADER
       bfType       As String * 2
       bfSize       As Long
       bfReserved1  As Integer
       bfReserved2  As Integer
       bfOffBits    As Long
End Type

Private Type BitmapInfoHeader
    biSize  As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BitmapInfoHeader
End Type


Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr

Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As LongByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As LongAs LongPtr

Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As LongByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As LongAs Long

Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr

Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long

Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long

Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As LongByVal nWidth As LongByVal crColor As LongAs LongPtr

Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As LongAs LongPtr

Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As LongByVal Y1 As LongByVal X2 As LongByVal Y2 As LongAs Long


Private Const PS_SOLID = 0
Private Const WHITE_BRUSH = 0
Private Const GRAY_BRUSH = 2
Private Const CWIDTH = 1500
Private Const CHEIGHT = 1500

投稿者 snowmansnow  (社会人) 投稿日時 2021/12/28 23:03:09

 こんばんは、魔界の仮面弁士様
 >MyDC1 で選択中のペンオブジェクトを削除してはまずいのではないでしょうか。
  >処分前に、最初のオブジェクトに復元しておいた方がよろしいかと。
 直してみました
 
    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 SelectObject(MyDC1, MyPen)
    DeleteObject (MyPen)
    Call SelectObject(MyDC1, MyBrush)
    DeleteObject (MyBrush)
 

 
    Call SelectObject(MyDC1, MyPen)
    Call Rectangle(MyDC1, f2, f1, f2 + 3, f1 + 3)
    Call SelectObject(MyDC1, MyPen)
    DeleteObject (MyPen)
 



投稿者 snowmansnow  (社会人) 投稿日時 2021/12/28 23:15:21

 こんばんは、魔界の仮面弁士様
> Dim MyDC0, MyDC1 As Long
直しました
    Dim MyDC0 As LongPtr
    Dim MyDC1 As LongPtr


> Private Const PS_SOLID = 0
直しました
Private Const PS_SOLID As Long = 0
Private Const WHITE_BRUSH As Long = 0
Private Const GRAY_BRUSH As Long = 2
Private Const CWIDTH As Long = 1500
Private Const CHEIGHT As Long = 1500


> Dim rs As Recordset
> Dim db As DAO.Database
直しました
 Dim rs As DAO.Recordset


> Set rs = db.OpenRecordset(Sql, dbOpenDynaset)
> rs.MoveFirst
直しました
 Set rs = db.OpenRecordset(Sql, dbOpenForwardOnly, dbReadOnly)
 Do Until rs.EOF


>そもそも、ループ中で何度も MyPen を作り直している理由が分からない…。
直せません・・・

投稿者 snowmansnow  (社会人) 投稿日時 2021/12/28 23:34:42

 こんばんは、魔界の仮面弁士様
  >どこでどういうエラーが出たのか分かりませんし、

     If i Mod 200 = 0 Then
  の所で、200分の1のデータに変更してるのですが、
  もっと多いデータだと、実行途中ではエラーは出ませんが、
  作成されるbitmapファイルが、真っ黒になって、何も描画されていない状態になります。
  描画できると、全体白いバックに、赤い小さな四角が沢山描画されます。

  エラーが出ないので、どこがどうしたエラーなのかわかりませんでした・・・
  

  
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2021/12/29 10:21:05
Rectangle するには、枠線のための「ペンオブジェクト」と
塗り潰し領域のための「ブラシオブジェクト」が必要となります。
枠線のみが必要な場合は、空ブラシ(NULL_BRUSH / HOLLOW_BRUSH)を割り当てます。

現状、最初に白背景で塗りつぶした後、ループ処理中のブラシは何が割り当てられていますか?
先の回答でも述べましたが、SelectObject で割り当ててある状態のペンやブラシを DeleteObject していないかも再確認しましょう。


> MyBrush = GetStockObject(WHITE_BRUSH)
CreateSolidBrush や CreateBrushIndirect で【作成】したブラシは DeleteObject が必須ですが、
GetStockObject で【取得】した定義済み(ストック)ブラシは DeleteObject すべきではありません。
(実際の所、後者を削除しても害は無いですが…)


> 直してみました
> Call SelectObject(MyDC1, MyPen)
> Call Rectangle(MyDC1, f2, f1, f2 + 3, f1 + 3)
> Call SelectObject(MyDC1, MyPen)
> DeleteObject (MyPen)
肝心の復元処理が無いままですよ。

まず、SelectObject の戻り値が描画オブジェクトのハンドルであることは御存知ですよね?
(HBITMAP, HBRUSH, HFONT, HPEN など)

それが分かっているからこそ、Long ではなく LongPtr に書き直したのだと思いますが、
であれば Call ステートメントではなく、戻り値を受け取って処理すべきではないでしょうか。

Rectangle や DeleteObject の戻り値は成否を表す BOOL なので、失敗の恐れが無い場合は
Call ステートメントを使うのも分かりますが…SelectObject の場合は戻り値も必要かと。

言語は違いますが、下記の WM_PAINT の処理を見てください。
http://kaitei.net/winapi/pens-brushes/

抜粋するとこんな感じです。
// ペンとブラシを選択
hpenPrev = (HPEN) SelectObject(hdc, hpen);
hbrPrev = (HBRUSH) SelectObject(hdc, hbr);

Rectangle(hdc, 50, 50, 200, 150);

// 元のペンとブラシを選択
SelectObject(hdc, hpenPrev);
SelectObject(hdc, hbrPrev);


snowmansnow  さんが書き直したコードでは、上記の処理が
 SelectObject(hdc, hpen);
 SelectObject(hdc, hbr);
 Rectangle(hdc, 50, 50, 200, 150);
 SelectObject(hdc, hpen);
 SelectObject(hdc, hbr);
になってしまっています。これでは復元処理になりません。
先に紹介した URL と今回の URL の内容を確認しつつ、もう一度コードを見直してみましょう。


> DeleteObject (MyPen)
修正前のコードでは Call DeleteObject(MyPen) で
修正後のコードでは DeleteObject (MyPen) なのは何故ですか?
Call ステートメントの表記揺れが気にかかりました。

そもそも Call 表記に揃えるというのなら、rs.MoveNext メソッドも Call を付けるものかと
思いましたが、もしかして、API にのみあえて Call を付けているということなのでしょうか。

いずれにせよ修正後の方は、括弧の記述が不自然です。
現状の『DeleteObject (MyPen)』という記述を Call 記法に書き換えた場合、
『Call DeleteObject((MyPen))』という意味になってしまいます。

『DeleteObject MyPen』と記述すれば、Call 記法で言うところの
『Call DeleteObject(MyPen)』相当の記述になります。

Call を使うか否かはお任せしますが、引数一つの場合の括弧の付与については
Call 無しでは「DeleteObject MyPen」
Call 付きでは「Call DeleteObject(MyPen)」としましょう。


>> そもそも、ループ中で何度も MyPen を作り直している理由が分からない…。
> 直せません・・・
今回紹介した URL では
 ①初期処理(WM_CREATE メッセージ)の段階で描画オブジェクトを作成
 ②描画処理(WM_PAINT メッセージ) ではそれらを使って Rectangle を呼び出して描く
 ③終了処理(WM_DESTROY メッセージ)では使用済みのペンやブラシを処分
という流れになっていますよね。

今回のプログラムも同様で、
 ①ループ前(Do Until rs.EOF より前)の段階で描画オブジェクトを作っておく
 ②ループ中(Do~Loop 内)では、Rectangle で描画
 ③ループ後(Loop より後)では、使用済みの描画オブジェクトを処分
という流れにするということです。
オブジェクトの生成・破棄や SelectObject を、ループ内で毎回行う必要があるとは思えなかったので。


> もっと多いデータだと、実行途中ではエラーは出ませんが、
描画元の BMP ファイルや、描画用の CSV などの具体的なデータがあるわけではないため、
回答側としても手軽に検証することができません。
(具体的にどういう結果になることを望んでいるのか、朧気にしか想像できていません)

何行目のどのデータの時に問題が出ているのかまで、具体的に追跡できますか?

・塗りつぶしブラシを明示的に指定してみた場合はどうなるか?
・1 レコードも処理しない状態でも問題が起きるのか?
・最初の 1 レコード目の描画時点で、既に問題が起きているのか?
・特定のレコードまでは問題が無く、あるところで急に黒くなるのか?
・問題が生じるタイミングは毎回同じなのか? それとも異なるのか?
・問題が生じ始めるタイミングが同じ場合、その時点の描画データの具体的な座標値は?
投稿者 snowmansnow  (社会人) 投稿日時 2021/12/29 22:03:04

 こんばんは、魔界の仮面弁士様
  御教授頂いた所などを直しましたら、エラーを再現できなくなりました。
  何十万件でも大丈夫なようでした。
  正しい宣言や、正しい構文だとエラーにならないようでした。
  エクセルでも動くことを確認しました。
  よろしかったら修正版も見て下さい
 
Option Explicit
Private Type BITMAPFILEHEADER
       bfType       As String * 2
       bfSize       As Long
       bfReserved1  As Integer
       bfReserved2  As Integer
       bfOffBits    As Long
End Type

Private Type BitmapInfoHeader
    biSize  As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type

Private Type BITMAPINFO
    bmiHeader As BitmapInfoHeader
End Type


Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr

Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As LongByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As LongAs LongPtr

Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As LongByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As LongAs Long

Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr

Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long

Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long

Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As LongByVal nWidth As LongByVal crColor As LongAs LongPtr

Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As LongAs LongPtr

Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As LongByVal Y1 As LongByVal X2 As LongByVal Y2 As LongAs Long

Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As LongAs LongPtr

Private Const PS_SOLID As Long = 0
Private Const WHITE_BRUSH As Long = 0
Private Const GRAY_BRUSH As Long = 2
Private Const CWIDTH As Long = 15000
Private Const CHEIGHT As Long = 15000
投稿者 snowmansnow  (社会人) 投稿日時 2021/12/29 22:06:35

 続きです
 
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, FalseFalse"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

 いかがでしょうか?
 まだ修正がおかしいでしょうか?
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2021/12/30 10:52:51
> 御教授頂いた所などを直しましたら、エラーを再現できなくなりました。
> 何十万件でも大丈夫なようでした。
改善されたようで良かったです!

気になる点を指摘しただけのあてずっぽう回答でしたが、
結局何が原因だったのか…ブラシ指定漏れですかね?
http://www.tt.rim.or.jp/~rudyard/torii009.html

> 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)
その表記が許されるのは VBA6 まであり、VBA7 では NG です。

GetDIBits の「LPVOID lpvBits」引数の Declare 宣言を
現状は ByRef lpBits As Any と翻訳しているようなので
 #If Win64
  Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0^, MyBMPInf, 0)
 #Else
  Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal 0&, MyBMPInf, 0)
 #End If
 ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
 Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)
と書くのが正しいです。LongPtr 型を示す型宣言文字は存在しないため、
bit 数に応じて LongLong リテラルと Long リテラルを使い分けます。

とはいえ、#If ディレクティブを使うのも煩わしいでしょうから、
 'Win32 では As Long = 0& 相当、Win64 では As LongLong = 0^ 相当の定数
 Const NullPtr As LongPtr = 0
をあらかじめ用意しておいて、それを用いて
 Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, ByVal NullPtr, MyBMPInf, 0)
のように呼ぶ方が簡単かと思います。

あるいは別案として、『ByRef lpBits As Any』を『ByVal lpBits As LongPtr』に変更して
 Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, 0, MyBMPInf, 0)
 ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
 Call GetDIBits(MyDC1, MyBMP, 0, CHEIGHT, VarPtr(MyBMPBits(0)), MyBMPInf, 0)
のように呼び出すのもありです。

もしくはバイナリ指定用の「ByRef lpBits As Byte」版と
NULL 指定用の「ByVal lpBits As LongPtr」版の 2 種類の宣言を Alias 指定して
 Call GetDIBitsNull(MyDC1, MyBMP, 0, CHEIGHT, 0, MyBMPInf, 0)
 ReDim MyBMPBits(MyBMPInf.bmiHeader.biSizeImage - 1)
 Call GetDIBitsByte(MyDC1, MyBMP, 0, CHEIGHT, MyBMPBits(0), MyBMPInf, 0)
などと使い分ける手法もあります。


Office 2016 以降では 64bit 環境が主流となっていますが、ネット上にあるサンプルは
32bit 時代のコードがまだまだ多いですし、VBA7 版でも Win64 対応が不十分なサンプルが
出回っていたりしますので、注意が必要ですね。


そして、似て非なる状況なのがこちら。

> MyDC0 = GetDC(0&)
> Call ReleaseDC(0&, MyDC0)
これも同様に、Win64 環境の場合は 0^ 、Win32 環境の場合は 0& を渡すべきなのですが、
こちらは Any ではなく、『ByVal h As LongPtr』な引数として Declare されていますので、
この場合は暗黙の型変換にお任せして、「0」表記でも「0&」表記でも大丈夫です。私は 0 派です。

極端な話、ここに「"0"」や「0.0」を渡したとしても正常に動作します。
(それが良いコードかどうかは別として!)

ちなみに、ハンドル(HDC とか HWND とか)というデータ型は、
Win32 では 32bit、Win64 では 64bit サイズではありますが、
互換性上の都合から、Win64 でも実際には下位 32bit 部しか
使われていなかったりします。ポインタとハンドルの違いというやつですね。

さらに丁寧に書くなら、Office 2007 以下にも配慮して、#If VBA7 Then ディレクティブを
併用することになりますが…2003 や 2007 等で動かすことが無い場合は冗長になりますね。
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2021/12/30 11:04:24
> 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

無意味な変数 i が残っているのは、前回の検証コードの名残ですかね。

さて…先にも指摘しましたが、ここの SelectObject は本当に必要ですか?
>>> オブジェクトの生成・破棄や SelectObject を、ループ内で毎回行う必要があるとは思えなかった

まず、矩形を一つ描くたびに、ペンとブラシを設定 & 復元している意図は何でしょうか。
座標値に応じて、別の色や太さで描きたいなどの理由が無いのであれば、
描画オブジェクトの割り当てや復元は、ループの前と後で処理するだけで良いと思います。
投稿者 (削除されました)  () 投稿日時 2021/12/30 11:29:09
(削除されました)
投稿者 (削除されました)  () 投稿日時 2021/12/30 11:42:49
(削除されました)
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2021/12/30 11:44:04
>>> 描画オブジェクトの割り当てや復元は、ループの前と後で処理するだけで良いと思います。

続き。このあたりも同様におかしいですね。

> hPen = CreatePen(PS_SOLID, 1, RGB(255, 0, 0))
> hBr = CreateSolidBrush(RGB(255, 0, 0))

現在の処理
For pre = 1 To 3
  Set db = OpenDatabase(…)
  Set rs = db.OpenRecordset(…)
    新しいペンとブラシを作成
    Do Until rs.EOF
        新しいペンとブラシを割り当て
        描画処理
        以前のペンとブラシに復元
        rs.MoveNext
    Loop
Next
rsとdbを処分
ペンとブラシを処分


修正案
新しいペンとブラシを作成
新しいペンとブラシを割り当て
For pre = 1 To 3
  Set db = OpenDatabase(…)
  Set rs = db.OpenRecordset(…)
    Do Until rs.EOF
        描画処理
        rs.MoveNext
    Loop
  rs.Close
  db.Close
Next
rsとdbを処分
以前のペンとブラシに復元
ペンとブラシを処分



> まだ修正がおかしいでしょうか?
あとは「インデント(字下げ)」が統一されていない点が気にかかりました。


> MyStrFile = "街区データを置いたフォルダ\"& \tmp00d.bmp" 
ここの文法エラーは横に置いておくとして…。


> Dim a As String
> a = Now()
> MsgBox a & "-" & Now()
本筋ではありませんが、できればここも見直した方が望ましいです。

変数宣言を Dim a As Date ではなく As String とするのであれば、
FormatDateTime 関数や Format$ 関数等を使って、明示的に文字列変換するべきでしょう。
あるいは Date$ や Time$ のように、最初から文字列型で返すコードを使うとか。

VBA には Option Strict が無いので、データ型の違いに気づくには慣れが必要かも。
投稿者 snowmansnow  (社会人) 投稿日時 2021/12/30 22:23:05

 こんばんは、魔界の仮面弁士様
 御教授ありがとうございます
 都道府県ですが44以上だと、メモリが足りませんのエラーになります。
 また、赤色が黒になってしまいました。
 何が原因でしょうか?

 テスト環境ですが、
 アクセスでもエクセルでも動きます。


 既存のビットマップの用意は必要ございません。新規に作成されます。

 必用なCSVは、以下の方法で入手いただくとありがたいです
 https://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi
 を開きます
 イ)
  都道府県単位のファイルを指定してダウンロードしたい場合、
   都道府県単位ボタンを押してください。という表示の
 「都道府県単位」というボタンを押します
ロ)
 都道府県選択
  以下の一覧からダウンロードしたい都道府県をチェックし、
  選択ボタンを押してください。という表示の下の
 「北海道」にチェックを入れます
 下の方の
  「選択」というボタンを押します。
ハ)
  該当するファイルは以下のとおりです。
  ダウンロードしたいファイルをチェックし、選択ボタンを押してください。
  上か下の
  「全ての街区レベルを選択」にチェックを入れます
  「選択」ボタンを押します
ニ)
  利用約款の表示が出ますので、読んで
  「同意します」というボタンを押します。
ホ)
  該当するファイルは以下のとおりです。
  ダウンロードボタンをクリックしてファイルをダウンロードしてください。という表示になりますので
  右下部の
  「ダウンロード」ボタンを押します
ヘ)
  ブラウザがダウンロードしますか?と聞いてきますので、「ok」ボタンを押します
ト)
  ZIPファイル(01000-19.0a.zip)がDLされます
  任意のフォルダに入れて、解凍すると、
  フォルダ(01000-19.0a\01000-19.0a\)の中に
  CSV(01_2020.csv)ができていると思います
  (他の都道府県は、北海道:01の所が県別に数字が変わります)

 北海道の選択を全部にすると、全部dlできます

 


 



投稿者 snowmansnow  (社会人) 投稿日時 2021/12/30 22:24:26

  直したコードです
 
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, FalseFalse"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