[[20190315150626]] 『ビットマップオブジェクトをDeleteObjectしなかっ』(中途B) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『ビットマップオブジェクトをDeleteObjectしなかったらどうなるのでしょう?』(中途B)

 スクリーンキャプチャを題材にAPIの勉強をしています。

 すべてUserformモジュールの中で行っている事なのですが、
 CreateCompatibleBitmapや、CreateDIBSectionでビットマップオブジェクトを作成する処理を
 ループの中で繰り返し行っており、
 それをDeleteObjectし忘れてた事に、後になって気付きました。

 ただ、この状態でもUserform自体は目的の動作をしてくれており、何ら問題ない様に見えます。

 「用が済んだら消しておく」という類の処理であろうとは推測しているのですが、
 消さなかったらどうなる(どの様な不都合が生ずる)のか? とか、あまり理解出来ていません。
 (そもそもAPI自体まだよく解ってません)

 そう言えばVBAの中でも、
 オブジェクト型変数にNothingを入れてから処理を終わる
 という書き方をしているコード例も多く見かけますが、あれと似た様な理由なのかな?
(これについては当掲示板でも議論されているのを拝見しました [[20041124212113]]とか[[20090303232447]]とか)

 でもこれはAPIの話なので、また違ってくる(もっと深刻なのでは? って)気もします。
 何か見えない部分で不都合が起こっているのでしょうか?

< 使用 Excel:Excel2010、使用 OS:Windows7 >


DeleteObjectとかを忘れると、メモリが開放されなくてメモリリークが起こった気がします。

試しにタスクマネージャーでメモリを見ながらループを回してみては如何でしょうか。

たぶんExcelを終了させても完全には開放されない部分が残るのではないかと。

あとbmpファイルを操作している場合、ファイルがロックされて開放できなくなるという問題が起きたような気がします。

(_) 2019/03/15(金) 17:00


 _さん、ありがとうございます。

 >メモリリーク
 をキーワードに自分でも少し調べてみましたが、
 解放し忘れたら、やがてオブジェクト生成の上限に達し、新たなオブジェクトの生成に失敗する
 みたいな事が書いてありました。
 なるほど、それはマズいですね。

 >試しにタスクマネージャーでメモリを見ながらループを回してみては
 やってみました。
 Excelプロセスのワーキングセット値の変化を追ってみたのですが、
 何だか、微妙です。
 増えたり減ったりして、あまり目立った変化には見えないです。
 (でも、それはそれでおかしいですよね...)

 >bmpファイルを操作している場合、ファイルがロックされて
 なるほど。今回ファイル操作はしてないのですが、そっち方面の事象もある訳ですね。

 ループ中のメモリについては、
 ちょっと何パターンか試してみて、また報告します。

(中途B) 2019/03/15(金) 19:54


 何となく分かった(気になってるだけかも知れませんが)のでご報告に参りました。
 結論的にはやはり、_さんの仰る通り、ループ中のメモリは増加の一途でした。

 で、なぜ先程試してみた時にはその様に見えなかったのか、ですが、
 まず、今回使用しているUserformモジュール貼りますね。
 何せ勉強用モジュールなので落書だらけですが^^;
 (ついでに突っ込み所があれば指摘して頂きたいですねぇ^^;)

 本件に関する着目点はコード内に「★」印でコメントしてある箇所です。
 ***************************************************************************************************************

    Option Explicit
    Rem API宣言-------------------------------------------------------------------------------------------------
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Type POINTAPI
        x As Long
        Y As Long
    End Type
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Sub Sleep Lib "KERNEL32.dll" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function BitBlt Lib "gdi32" ( _
        ByVal hdcDest As LongPtr, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hDCSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, _
        ByVal dwRop As Long) As Long
    Private Declare PtrSafe Function StretchBlt Lib "gdi32" ( _
        ByVal hdcDest As LongPtr, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hDCSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
        ByVal dwRop As Long) As Long
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(7) As Byte
    End Type
    Private Type PicBmp
        Size As Long
        Type As Long
        hBmp As Long
        hPal As Long
        Reserved As Long
    End Type
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long
    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 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
    Private 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

    Private Const DIB_RGB_COLORS = 0&
    Private Const vbPicTypeBitmap As Long = 1
    Private Const vbSrcCopy As Long = &HCC0020
    Private Const SM_CXSCREEN = 0
    Private Const SM_CYSCREEN = 1
    Rem モジュールレベル変数------------------------------------------------------------------------------------
    Private LoopFlg As Boolean, PickedFlg As Boolean
    Private WithEvents ButtonGetPx As MSForms.ToggleButton
    Private WithEvents ButtonOK    As MSForms.CommandButton
    Private Label1 As MSForms.Label
    Private Label2 As MSForms.Label
    Private Image1 As MSForms.Image
    Private LabelCur As MSForms.Label
    Rem メソッド------------------------------------------------------------------------------------------------
    Public Function GetPixelRGB(ResRGB As Long) As Boolean
        ButtonOK.Visible = True
        Me.Show 1
        If IsPicked Then
            ResRGB = Me.BackColor
            GetPixelRGB = True
        End If
        Unload Me
    End Function
    Rem プロパティ(主にオートメーションエラー回避)--------------------------------------------------------------
    Private Property Get IsRunning() As Boolean
        IsRunning = LoopFlg
    End Property
    Private Property Let IsRunning(newBool As Boolean)
        If newBool = LoopFlg Then Exit Property
        LoopFlg = newBool
        If LoopFlg Then
            Me.Caption = "実行中([Enter]で取得。[Esc]で中止)"
            IsPicked = False
        Else
            Me.Caption = "待機中(スポイトボタンから実行)"
            ButtonGetPx.Value = False
        End If
    End Property
    Private Property Get IsPicked() As Boolean
        IsPicked = PickedFlg
    End Property
    Private Property Let IsPicked(newBool As Boolean)
        If newBool = PickedFlg Then Exit Property
        PickedFlg = newBool
        If PickedFlg Then
            ButtonOK.Enabled = True
        Else
            ButtonOK.Enabled = False
        End If
    End Property
    Rem 内部イベント処理----------------------------------------------------------------------------------------
    Private Sub ButtonGetPx_Click()
        If ButtonGetPx.Value Then
            Call Capture
        Else
            IsRunning = False
        End If
    End Sub
    Private Sub ButtonOK_Click()
        Me.Hide
    End Sub
    Private Sub UserForm_Initialize()
        Set ButtonGetPx = Me.Controls.Add("Forms.ToggleButton.1", "ButtonGetPx")
        With ButtonGetPx
            .Top = 3: .Left = 6: .Width = 21: .Height = 21
            .PicturePosition = fmPicturePositionCenter
            .Picture = Application.CommandBars.GetImageMso("PickUpStyle", 16, 16)
            .TabStop = False
        End With
        Set Label1 = Me.Controls.Add("Forms.Label.1", "Label1")
        With Label1
            .Top = 3: .Left = 30: .Width = 96: .Height = 12
            .BackStyle = fmBackStyleTransparent
            .SpecialEffect = fmSpecialEffectSunken
            .Caption = "座標:"
        End With
        Set Label2 = Me.Controls.Add("Forms.Label.1", "Label2")
        With Label2
            .Top = 15: .Left = 30: .Width = 96: .Height = 12
            .BackStyle = fmBackStyleTransparent
            .SpecialEffect = fmSpecialEffectSunken
            .Caption = "RGB:"
        End With
        With Me.Controls.Add("Forms.Label.1", "Label3")
            .Top = 27: .Left = 6: .Width = 96 + 24: .Height = 24
            .BackStyle = fmBackStyleTransparent
            .Caption = "[Ctrl] 3x3ピクセル平均色" & vbCrLf & "[Shift] 拡大図を更新しない"
        End With
        Set Image1 = Me.Controls.Add("Forms.Image.1", "Image1")
        With Image1
            .Top = 3.75: .Left = 127.5: .Width = 31.5: .Height = 31.5
            .SpecialEffect = fmSpecialEffectBump
    '        .PictureSizeMode = fmPictureSizeModeStretch
        End With
        Set LabelCur = Me.Controls.Add("Forms.Label.1", "LabelCur")
        With LabelCur
            .Top = Image1.Top + 15.75 - 1.5 - 0.75: .Left = Image1.Left + 15.75 - 1.5 - 0.75: .Width = 4.5: .Height = 4.5
            .BackStyle = fmBackStyleTransparent
            .BorderStyle = fmBorderStyleSingle
        End With
        Dim r As Long, c As Long
        For r = 1 To 9
            For c = 1 To 9
                With Me.Controls.Add("Forms.Label.1", "LabelR" & r & "C" & c)
                    .Top = 3 + (r - 1) * 4.5: .Left = 160.5 + (c - 1) * 4.5: .Width = 5.25: .Height = 5.25
                    .BorderStyle = fmBorderStyleSingle
                End With
            Next
        Next
        Set ButtonOK = Me.Controls.Add("Forms.CommandButton.1", "ButtonOK")
        With ButtonOK
            .Top = 21: .Left = 204: .Width = 30: .Height = 21
            .Caption = "OK"
            .TakeFocusOnClick = False
            .TabStop = False
            .Enabled = False
            .Visible = False
        End With
        Me.Caption = "待機中(スポイトボタンから実行)"
        Me.Width = 240
        Me.Height = 67.5
    End Sub
    Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        IsRunning = False
        If Not Image1.Picture Is Nothing Then Call DeleteObject(Image1.Picture.handle) '★(3):最後のBMPの削除
    End Sub
    Rem 内部処理関数--------------------------------------------------------------------------------------------
    Private Sub Capture()
        Dim hDC As LongPtr, pt As POINTAPI, ptMax As POINTAPI
        Dim c As Long, lState As Integer
        Dim r As Long, RGBs() As Variant
        Dim hPicOld As LongPtr '★(0):前回のhBmp記録用変数
        ptMax.x = GetSystemMetrics(SM_CXSCREEN) - 1
        ptMax.Y = GetSystemMetrics(SM_CYSCREEN) - 1
        IsRunning = True
        Application.EnableCancelKey = xlDisabled
        hDC = GetDC(0)
        Do While IsRunning
            Call GetCursorPos(pt)
            If GetAsyncKeyState(vbKeyControl) Then 'Ctrl押下中は3ピクセル四方平均色
                RGBs = GetRGBsByhWnd(0&, _
                    pt.x - IIf(pt.x <= 0, 0, 1), pt.Y - IIf(pt.Y <= 0, 0, 1), _
                    pt.x + IIf(pt.x >= ptMax.x, 0, 1), pt.Y + IIf(pt.Y >= ptMax.Y, 0, 1))
                c = AvgRGB(RGBs)
            Else
                c = GetPixel(hDC, pt.x, pt.Y) '←連続で呼び出すと意外に遅い。
    '            c = GetRGBsByhWnd(0&, pt.x, pt.Y, 1, 1)(1, 1) '←まだこっちのが速いくらい
            End If
    Rem プレビュー的な部分----------------------------------------------------------+
            Me.BackColor = c
            Label1.ForeColor = IIf(GetYfromRGB(c) < 0.5!, &HFFFFFF, &H0&)
            Label2.ForeColor = Label1.ForeColor
            Me.Controls("Label3").ForeColor = Label1.ForeColor
            Label1.Caption = "座標: X= " & pt.x & " Y= " & pt.Y
            Label2.Caption = "RGB: " & Join(SplitRGB(c), ", ")
            If GetAsyncKeyState(vbKeyShift) = 0& Then 'Shift押下中は拡大図の描画を更新しない
                Rem 実験1: 周囲9ピクセル四方をキャプチャしてImageコントロールにPictureとして渡す
                If Not Image1.Picture Is Nothing Then hPicOld = Image1.Picture.handle       '★(1):前回のhBmp覚えといて
                Set Image1.Picture = CreatePictureByhWnd(0&, pt.x - 4, pt.Y - 4, 9, 9, 4)   '      新しいBMPに置き換えてから
                If hPicOld Then Debug.Print DeleteObject(hPicOld), "★"                     '★(2):前回のBMPを削除 ←失敗する
                LabelCur.BorderColor = Label1.ForeColor
                Rem 実験2: 同じく周囲9ピクセル四方のRGB値の配列を取得し、対応するラベルを塗る
                RGBs = GetRGBsByhWnd(0&, pt.x - 4, pt.Y - 4, pt.x + 4, pt.Y + 4)
                For r = 1 To 9
                    For c = 1 To 9
                        Me.Controls("LabelR" & r & "C" & c).BackColor = RGBs(r, c)
                    Next
                Next
            End If
    Rem ----------------------------------------------------------------------------+
            DoEvents
            Sleep 50
            lState = GetAsyncKeyState(vbKeyReturn) '上位ビット(&H8000&)が今回:下位ビット(&H1&)が前回以降の状態
            If lState Then
                IsPicked = True
                IsRunning = False  '今回または前回以降押されてれば止める(上位ビットだけで判定しない)
            ElseIf GetAsyncKeyState(vbKeyEscape) Then
                IsRunning = False  'Escキーで中止(lStateはゼロのままループを抜ける)
            End If
        Loop
        Call ReleaseDC(0, hDC)
        Application.EnableCancelKey = xlInterrupt
    End Sub
    Private Function SplitRGB(aRGB As Long, Optional Percentage As Boolean) As Variant
    Rem RGB値をR,G,Bの各要素の配列に変換
        Dim i As Long, Ary(0 To 2) As Variant
        For i = 0 To 2
            Ary(i) = (aRGB \ &H100& ^ i) Mod &H100&
            If Percentage Then Ary(i) = CSng(Ary(i) / &HFF&)
        Next
        SplitRGB = Ary
    End Function
    Private Function GetYfromRGB(aRGB As Long) As Single
    Rem RGB値から輝度(0以上1以下の数値)を算出 (HSLカラーモデルとの混同を避ける為「Y」で表現)
        Const prmR = 0.298912!, prmG = 0.586611!, prmB = 0.114478!
        Dim vRGB() As Variant
        vRGB = SplitRGB(aRGB)
        GetYfromRGB = vRGB(0) * prmR + vRGB(1) * prmG + vRGB(2) * prmB
        GetYfromRGB = GetYfromRGB / &HFF&
        If GetYfromRGB > 1! Then GetYfromRGB = 1!
        If GetYfromRGB < 0! Then GetYfromRGB = 0!
    End Function

    Private Function CreatePictureByhBmp(ByVal hBmp As LongPtr) As IPictureDisp
    Rem ビットマップハンドルからIPictureを作る
        Dim IID_IDispatch As GUID, Bmp As PicBmp, IPic As IPicture
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With
        With Bmp
            .Size = Len(Bmp)
            .Type = vbPicTypeBitmap
            .hBmp = hBmp
        End With
        Call OleCreatePictureIndirect(Bmp, IID_IDispatch, 1, IPic)
        Set CreatePictureByhBmp = IPic
    End Function
    Private Function CreatePictureByhWnd(ByVal hWndSrc As LongPtr, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long, Optional ByVal Zoom As Single = 1!) As IPictureDisp
    Rem ウインドウハンドルからIPictureを作る(Zoom:縮尺指定(但しアスペクト比変更には非対応))
        If Zoom <= 0 Then Zoom = 1!
        Dim Rtn As LongPtr
        Dim hDCSrc As LongPtr, hDCMemory As LongPtr
        Dim hBmp As LongPtr, hBmpPrev As LongPtr
        hDCSrc = GetWindowDC(hWndSrc)
        hDCMemory = CreateCompatibleDC(hDCSrc)
        hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc * Zoom, HeightSrc * Zoom)
        hBmpPrev = SelectObject(hDCMemory, hBmp)
        Rtn = StretchBlt(hDCMemory, 0, 0, WidthSrc * Zoom, HeightSrc * Zoom, hDCSrc, LeftSrc, TopSrc, WidthSrc, HeightSrc, vbSrcCopy)
        hBmp = SelectObject(hDCMemory, hBmpPrev)
        Call DeleteDC(hDCMemory)
        Call ReleaseDC(hWndSrc, hDCSrc)
        If Rtn Then Set CreatePictureByhWnd = CreatePictureByhBmp(hBmp)
    '    Call DeleteObject(hBmp) 'ココでビットマップオブジェクトを破棄してしまったら絵が消えてしまう。どうしよ...
    End Function
    Private Function GetRGBsByhWnd(ByVal hWndSrc As LongPtr, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal RightSrc As Long, ByVal BottomSrc As Long) As Variant
    Rem ウインドウハンドルから各ピクセルのRGB値を2次元配列で返す
        Dim WidthSrc As Long, HeightSrc As Long
        Dim Rtn As LongPtr
        Dim hDCSrc As LongPtr, hDCMemory As LongPtr
        Dim hBmp As LongPtr, hBmpPrev As LongPtr
        Dim bi As BITMAPINFO
        Dim RGBBuff() As Byte, r As Long, c As Long, vRGB() As Variant
        WidthSrc = RightSrc - LeftSrc + 1
        HeightSrc = BottomSrc - TopSrc + 1
        hDCSrc = GetWindowDC(hWndSrc)
        hDCMemory = CreateCompatibleDC(hDCSrc)
        With bi.bmiHeader
            .biSize = Len(bi.bmiHeader)
            .biWidth = WidthSrc
            .biHeight = -HeightSrc 'トップダウン走査
            .biPlanes = 1
    '        .biBitCount = 24 '1pxあたり[BB][GG][RR]の3バイト。(だけど1行あたり4バイトの倍数にサイズ補正が必要。余剰部分が各行の末尾に残るので、後で配列をちょん切る必要がある)
    '        .biSizeImage = -Int(-(WidthSrc * 3) / 4) * 4 * HeightSrc 'って事でサイズ補正(なんか自動で補正入るっぽいけど)やっぱ32bitのが楽なのかもな・・・
            .biBitCount = 32 '1pxあたり[BB][GG][RR][&HFF]の4バイト。(かと言ってLong配列で受け取ったらバイトオーダー逆転してる。そのままHTMLカラーコードに使っちゃうには良いかも?)
            .biSizeImage = WidthSrc * 4 * HeightSrc '必ず1行あたり4バイトの倍数になるのでサイズ補正不要
        End With
        hBmp = CreateDIBSection(hDCSrc, bi, DIB_RGB_COLORS, 0&, 0&, 0&)
        hBmpPrev = SelectObject(hDCMemory, hBmp)
        Rtn = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
        If Rtn Then
    '        ReDim RGBBuff(1 To -Int(-(WidthSrc * 3) / 4) * 4, 1 To HeightSrc)
            ReDim RGBBuff(1 To WidthSrc * 4, 1 To HeightSrc)
            Rtn = GetDIBits(hDCMemory, hBmp, 0&, HeightSrc, RGBBuff(1, 1), bi, DIB_RGB_COLORS)
        End If
        hBmp = SelectObject(hDCMemory, hBmpPrev)
        Debug.Print DeleteObject(hBmp), "◆" 'コメントアウトするとメモリが食い潰されていく
        Call DeleteDC(hDCMemory)
        Call ReleaseDC(hWndSrc, hDCSrc)
        If Rtn = 0 Then Exit Function
        ReDim vRGB(1 To HeightSrc, 1 To WidthSrc)
        For r = 1 To HeightSrc
            For c = 1 To WidthSrc
    '            vRGB(r, c) = RGBBuff(c * 3, r) + RGBBuff(c * 3 - 1, r) * &H100& + RGBBuff(c * 3 - 2, r) * &H100& ^ 2
                vRGB(r, c) = RGBBuff(c * 4 - 1, r) + RGBBuff(c * 4 - 2, r) * &H100& + RGBBuff(c * 4 - 3, r) * &H100& ^ 2
            Next
        Next
        GetRGBsByhWnd = vRGB
    End Function
    Private Function AvgRGB(AryRGB() As Variant) As Long
    Rem RGB値の配列から単純平均RGB値を算出
        Dim i As Variant, vRGB() As Variant
        Dim Cnt As Long, Avg(0 To 2) As Variant, j As Long
        For Each i In AryRGB
            Cnt = Cnt + 1
            vRGB = SplitRGB(CLng(i))
            For j = 0 To 2
                Avg(j) = Avg(j) + vRGB(j)
            Next
        Next
        For j = 0 To 2
            Avg(j) = Avg(j) \ Cnt
        Next
        AvgRGB = Avg(0) + Avg(1) * &H100& + Avg(2) * &H100& ^ 2
    End Function
    Rem 標準モジュールでの使用例 ===================================
    'Sub ColorPicker_test()
    '    Dim c As Long
    '    If UserForm1.GetPixelRGB(c) Then MsgBox "&H" & Hex(c) & "&"
    'End Sub
    Rem ============================================================

 ***************************************************************************************************************

 ★印の部分((0)から(3)までの4ヵ所)が、DeleteObjectし忘れてた事に気付いて追記した部分なのですが、
 ★(2)のDeleteObjectは戻値ゼロで失敗してしまいます。

    If Not Image1.Picture Is Nothing Then hPicOld = Image1.Picture.handle       '★(1):前回のhBmp覚えといて
    Set Image1.Picture = CreatePictureByhWnd(0&, pt.x - 4, pt.Y - 4, 9, 9, 4)   '      新しいBMPに置き換えてから
    If hPicOld Then Debug.Print DeleteObject(hPicOld), "★"                     '★(2):前回のBMPを削除 ←失敗する

 試しに
 Set Image1.Picture・・・
 の行の手前でDeleteObjectしてみたら、こちらは成功しました。

    If hPicOld Then Debug.Print DeleteObject(hPicOld), "★"                     '★(2):前回のBMPを削除して ←成功する
    Set Image1.Picture = CreatePictureByhWnd(0&, pt.x - 4, pt.Y - 4, 9, 9, 4)   '      新しいBMPに置き換える

 ここにDeleteObjectがなくてもタスクマネージャーでメモリの増加傾向が見えなかった事と併せると、
 どうやらImage1に新しいPictureがSetされたことにより、
 前回のビットマップオブジェクトは自動的にメモリから削除されたのではないか?
 と想像してます。

 対して、GetRGBsByhWnd内にある◆印付きのDeleteObjectは、
 試しにこれをコメントアウトすると、_さんの仰る通り、ループ中のメモリは少しずつ増加していきました。
 こちらのビットマップはこの関数内でしか使われないので、関数内で削除しない限り解放されないハズ。
 こっちには元々DeleteObject入れてあったので、気付くのが遅くなってしまいました。

 上記の想像が正しいとすれば、このモジュールについては★印部分の記述は不要ですね。

 という感じで、
 勝手に解釈して落ち着いております。

(中途B) 2019/03/15(金) 22:30


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.