bitmapに沢山追加したいです
投稿者 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, 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
よろしくお願いします。
投稿者 魔界の仮面弁士 (社会人)
投稿日時
2021/12/28 21:44:34
VBA7 な Access VBA が前提のようですが、API 宣言が結構間違っていませんか?
LongPtr にすべきところが Long になってたり、
Any に対して Win32/Win64 判定の無いまま 「ByVal 0&」 が無条件に渡されていたり…。
> 約３０００件程度を上限に、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
にしますね。編集するわけでも無いので、カーソルも前方参照モードを選択。
LongPtr にすべきところが Long になってたり、
Any に対して Win32/Win64 判定の無いまま 「ByVal 0&」 が無条件に渡されていたり…。
> 約３０００件程度を上限に、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 Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As 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 Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As 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
の所で、２００分の１のデータに変更してるのですが、
もっと多いデータだと、実行途中ではエラーは出ませんが、
作成される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/
抜粋するとこんな感じです。
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 レコード目の描画時点で、既に問題が起きているのか?
・特定のレコードまでは問題が無く、あるところで急に黒くなるのか?
・問題が生じるタイミングは毎回同じなのか? それとも異なるのか?
・問題が生じ始めるタイミングが同じ場合、その時点の描画データの具体的な座標値は?
塗り潰し領域のための「ブラシオブジェクト」が必要となります。
枠線のみが必要な場合は、空ブラシ（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 Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As 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 Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As 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, 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
いかがでしょうか？
まだ修正がおかしいでしょうか？
投稿者 魔界の仮面弁士 (社会人)
投稿日時
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 等で動かすことが無い場合は冗長になりますね。
> 何十万件でも大丈夫なようでした。
改善されたようで良かったです！
気になる点を指摘しただけのあてずっぽう回答でしたが、
結局何が原因だったのか…ブラシ指定漏れですかね?
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 を、ループ内で毎回行う必要があるとは思えなかった
まず、矩形を一つ描くたびに、ペンとブラシを設定 & 復元している意図は何でしょうか。
座標値に応じて、別の色や太さで描きたいなどの理由が無いのであれば、
描画オブジェクトの割り当てや復元は、ループの前と後で処理するだけで良いと思います。
> 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))
現在の処理
修正案
> まだ修正がおかしいでしょうか？
あとは「インデント(字下げ)」が統一されていない点が気にかかりました。
> 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 が無いので、データ型の違いに気づくには慣れが必要かも。
続き。このあたりも同様におかしいですね。
> 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
こんばんは、魔界の仮面弁士様
御教授ありがとうございます
都道府県ですが４４以上だと、メモリが足りませんのエラーになります。
また、赤色が黒になってしまいました。
何が原因でしょうか？
テスト環境ですが、
アクセスでもエクセルでも動きます。
既存のビットマップの用意は必要ございません。新規に作成されます。
必用なＣＳＶは、以下の方法で入手いただくとありがたいです
https://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi
を開きます
イ）
都道府県単位のファイルを指定してダウンロードしたい場合、
都道府県単位ボタンを押してください。という表示の
「都道府県単位」というボタンを押します
ロ）
都道府県選択
以下の一覧からダウンロードしたい都道府県をチェックし、
選択ボタンを押してください。という表示の下の
「北海道」にチェックを入れます
下の方の
「選択」というボタンを押します。
ハ）
該当するファイルは以下のとおりです。
ダウンロードしたいファイルをチェックし、選択ボタンを押してください。
上か下の
「全ての街区レベルを選択」にチェックを入れます
「選択」ボタンを押します
ニ）
利用約款の表示が出ますので、読んで
「同意します」というボタンを押します。
ホ）
該当するファイルは以下のとおりです。
ダウンロードボタンをクリックしてファイルをダウンロードしてください。という表示になりますので
右下部の
「ダウンロード」ボタンを押します
ヘ）
ブラウザがダウンロードしますか？と聞いてきますので、「ｏｋ」ボタンを押します
ト）
ＺＩＰファイル（01000-19.0a.zip）がＤＬされます
任意のフォルダに入れて、解凍すると、
フォルダ（01000-19.0a\01000-19.0a\)の中に
ＣＳＶ（01_2020.csv）ができていると思います
（他の都道府県は、北海道：０１の所が県別に数字が変わります）
北海道の選択を全部にすると、全部ｄｌできます
投稿者 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, 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
こんばんは、国土交通省の街区ｃｓｖデータをbitmapに描画しようとしました。
'https://nlftp.mlit.go.jp/cgi-bin/isj/dls/_choose_method.cgi
'http://www5a.biglobe.ne.jp/~kkw_pl2/kkwvbs/vbabitmap.htmを参考に作ってみました。
でも、約３０００件程度を上限に、bitmapに描画できないエラーになりました。
１都道府県約３０万件、４７都道府県約１４００万件を描画してみたいです。