| Вопрос: Вопрос!!! | Добавлено: 06.04.03 10:07 |
Автор вопроса:  pavel-naumov
|
|
У меня к Вам, уважаемые специалисты по VB, вот такой вопрос. Есть следующий код: Private Declare Function GetGuiResources Lib "user32.dll" (ByVal hProcess As Long, ByVal uiFlags As Long) As Long Private Declare Function GetCurrentProcess Lib "kernel32" () As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Dim f1 As Long Dim f2 As Long Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn 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 Const GR_GDIOBJECTS = 0 Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With With Pic .Size = Len(Pic) .Type = vbPicTypeBitmap .hBmp = hBmp .hPal = hPal End With R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic) Set CreateBitmapPicture = IPic End Function Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture hDCMemory = CreateCompatibleDC(hDCSrc) hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc) hBmpPrev = SelectObject(hDCMemory, hBmp) R = StretchBlt(hDCMemory, 0, 0, f1, f2, hDCSrc, LeftSrc, TopSrc, WidthSrc, HeightSrc, vbSrcCopy) hBmp = SelectObject(hDCMemory, hBmpPrev) Set hDCToPicture = CreateBitmapPicture(hBmp, hPal) End Function Private Sub Form_Load() f1 = (Form1.Width - 100) / Screen.TwipsPerPixelX f2 = (Form1.Height - 400) / Screen.TwipsPerPixelY Timer1.Interval = 1 Timer1.Enabled = True End Sub Private Sub Form_Resize() f1 = (Form1.Width - 100) / Screen.TwipsPerPixelX f2 = (Form1.Height - 400) / Screen.TwipsPerPixelY End Sub Private Sub Timer1_Timer() Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY) End Sub В результате его выполнения "утекают" ресурсы - GDI, вернее создаются GDI Objects, и после определенного времени начинаются "глюки". Вставлял в процедуру Timer следующий код: Private Sub Timer1_Timer() Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY) asd1 = DeleteDC(GetDC(0)) asd2 = DeleteDC(hDCMemory) asd3 = DeleteObject(hBmp) asd4 = DeleteObject(hBmpPrev) asd5 = DeleteObject(GetDC(0)) Debug.Print "Использовано ресурсов: " & GetGuiResources(GetCurrentProcess, GR_USEROBJECTS) End Sub не помогает. Подскажите, пожалуйста, что можно сделать, чтобы избежать "утечки". Пока нашел такой выход: Private Sub Timer1_Timer() Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY) asd1 = DeleteDC(GetDC(0)) asd2 = DeleteDC(hDCMemory) asd3 = DeleteObject(hBmp) asd4 = DeleteObject(hBmpPrev) asd5 = DeleteObject(GetDC(0)) Debug.Print "Использовано ресурсов: " & GetGuiResources(GetCurrentProcess, GR_USEROBJECTS) If GetGuiResources(GetCurrentProcess, GR_GDIOBJECTS) > 1000 Then Shell App.Path & "\" & App.EXEName, vbNormalFocus End End If End Sub Т.к. с закрытием программы удаляются все созданные ей объекты. Но ведь это не правильно!!! Да и мелькание формы заметно. Заранее благодарю за помощь. Павел Наумов. |
| Ответы | Всего ответов: 4 |
|
Номер ответа: 1 Автор ответа:  Gravity Вопросов: 6 Ответов: 120 |
Профиль | Цитата | #1 | Добавлено: 06.04.03 16:15 |
Вот это да ... загоны  
|
||
|
Номер ответа: 2 Автор ответа:  ZeusICQ: 161801353 Вопросов: 63 Ответов: 220 |
Web-сайт: Профиль | Цитата | #2 | Добавлено: 06.04.03 18:24 |
|
Обычно всем впадлу такие коды рассматривать, да ещё и искать в них ошибку, или че там у тебя.... 2GRAVITY: А что, reflex сдох??? Зачем редирект на хотмайл? У меня 404 не найдена страница! |
||
|
Номер ответа: 3 Автор ответа:  GravityВопросов: 6 Ответов: 120 |
Профиль | Цитата | #3 | Добавлено: 06.04.03 21:16 |
как здох  ? всё вроде нормально, сегодня обновлял ... http://reflexsoft.narod.ru/index.html
|
||
|
Номер ответа: 4 Автор ответа:  CyRax   Разработчик Offline Client ICQ: 204447456 Вопросов: 180 Ответов: 4229 |
Web-сайт: Профиль | Цитата | #4 | Добавлено: 06.04.03 22:10 |
|
Лучше не проверяйте - может винда сойти с ума. Мне это напомнило фильм "Семья Тупых". Там жена Тупого с детьми вставили в дисковод "В" фотографию Тупого, в результате чего сгорела вся локальная сеть. |
||
Страница: 1 |