Visual Basic, .NET, ASP, VBScript
Новости | Примеры | Библиотека кодов | НеЧаВо | VBA | Справочник по VB | Справочник по WinAPI | ActiveX контролы | Статьи по VB | Мастерская разработчика | Форум VBNet | Яndex bar! | Голосование | Полезные программы | Магазин VBNet | Рассылка | Конкурсы | Юмор | Чат | Реклама на VBNet | Автора! | Ссылки | Бета-тестирование | Послать пример на сайт
 

   
   
     

Форум - Общий форум

Страница: 1 |

 

  Вопрос: Файл подкачки Добавлено: 29.03.08 21:37  

Автор вопроса:  Боцман | Web-сайт: Rus-Skipper.narod.ru | ICQ: 295725312 
Файл подкачки
Вот примерчик, скомпилируйте и посмторите через диспетчер задач,
файл подкачки будет расти, при более больших рисуках еще быстрее,
как его <обнулять?>
в форме
Const Rad As Currency = 1.74532925199433E-02
Private Sub Form_Load()
Timer1.Interval = 200
Picture1.AutoSize = True
Picture1.AutoRedraw = True
Picture1.Picture = LoadPicture("C:\WINDOWS\Штукатурка.bmp")
Picture2.AutoSize = True
Picture2.AutoRedraw = True
Picture2.BorderStyle = 0
Picture2.Picture = LoadPicture("C:\WINDOWS\\Паркет.bmp")

End Sub

Private Sub Form_Resize()
Picture2.BackColor = Picture2.Point(2, 2)
End Sub

Private Sub Timer1_Timer()
Picture1.Cls
TranspRotate Picture1.hdc, (Second(Time) * -6) * Rad, 128, 128, Picture2.Width, Picture2.Height, Picture2.Image.handle, Picture2.BackColor, 1, 1
'Picture1.Refresh
End Sub

в модуле:
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Const DIB_PAL_COLORS = 1
Public Const DIB_PAL_INDICES = 2
Public Const DIB_PAL_LOGINDICES = 4
Public Const DIB_PAL_PHYSINDICES = 2
Public Const DIB_RGB_COLORS = 0
Public Const SRCCOPY = &HCC0020
Public 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

Public Type BITMAPINFO
    Header As BITMAPINFOHEADER
    Bits() As Byte             '(Цвета)
End Type

Sub TranspRotate(Destdc As Long, Angle As Currency, x&, y&, W&, H&, ImgHandle&, Optional TranspColor&, Optional Alpha As Currency = 1, Optional pScale As Currency = 1, Optional px% = -32767, Optional py% = -32767)
  Dim P() As Byte
  Dim ProcessedBits() As Byte
  Dim dx As Currency, dy As Currency, tx As Currency, ty As Currency
  Dim ix As Integer, iy As Integer
  Dim Tmp&, CX&, CY&, XX&, YY&
  Dim TR As Byte, TB As Byte, TG As Byte
  Dim D() As Byte
  Dim BackDC As Long
  Dim BackBmp As BITMAPINFO
  Dim iBitmap As Long
  Dim TopL As Currency, TopR As Currency, BotL As Currency, BotR As Currency
  Dim TopLV As Currency, TopRV As Currency, BotLV As Currency, BotRV As Currency
  Dim pSin As Currency, PCos As Currency
  Dim PicBmp As BITMAPINFO, PicDC As Long
' максимальная ширину и высоту, в котором поворот может происходить
  Tmp = Int(Sqr(W * W + H * H)) * pScale
  'Готовим массивы пикселов
  ReDim D(3, Tmp - 1, Tmp - 1) 'фоновое изображение
  ReDim P(3, W - 1, H - 1)     ' исходное изображение
  ReDim ProcessedBits(3, Tmp - 1, Tmp - 1) ' результат вращения
  ' значения по умолчанию оси вращения
  If px = -32767 Then px = (W / 2)  'pivot x
  If py = -32767 Then py = (H / 2)  'pivot y
  
  '[Создайте Контекст - Копируют Backgroung - Получаем пикселы Фона
  With BackBmp.Header
      .biBitCount = 4 * 8
      .biPlanes = 1
      .biSize = 40
      .biWidth = Tmp
      .biHeight = -Tmp
  End With
  BackDC = CreateCompatibleDC(0)
  iBitmap = CreateDIBSection(BackDC, BackBmp, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)

  SelectObject BackDC, iBitmap
  'Копируйте фон к контексту
  BitBlt BackDC, 0, 0, Tmp, Tmp, Destdc, x - Tmp / 2, y - Tmp / 2, SRCCOPY
  GetDIBits BackDC, iBitmap, 0, Tmp, D(0, 0, 0), BackBmp, DIB_RGB_COLORS
  
  With PicBmp.Header
      .biBitCount = 4 * 8
      .biPlanes = 1
      .biSize = 40
      .biWidth = W
      .biHeight = -H
  End With
  PicDC = CreateCompatibleDC(0)
  SelectObject PicDC, ImgHandle
  GetDIBits PicDC, ImgHandle, 0, H, P(0, 0, 0), PicBmp, DIB_RGB_COLORS
'DeleteDC (PicDC)

  CX = Int((Tmp - W) / 2)
  CY = Int((Tmp - H) / 2)
  
  'Конвертируем к R, G,  B  формату   прозрачный цвет
  TR = TranspColor And &HFF&
  TG = (TranspColor And &HFF00&) / &H100&
  TB = (TranspColor And &HFF0000) / &H10000
  
  PCos = Cos(Angle) / pScale
  pSin = Sin(Angle) / pScale

  'Цикл через все пикселы исходного изображения
  For XX = -CX To Tmp - CX - 1
   For YY = -CY To Tmp - CY - 1
' Получаем кординаты вращения (дает исходную координату Изображения
'назначает координату для нового рисунка  x, y)
      tx = (XX - px) * PCos - (YY - py) * pSin + px
      ty = (XX - px) * pSin + (YY - py) * PCos + py
      ix = Int(tx)
      iy = Int(ty)
      dx = Abs(tx - ix)
      dy = Abs(ty - iy)
      ProcessedBits(0, XX + CX, YY + CY) = D(0, XX + CX, YY + CY)
      ProcessedBits(1, XX + CX, YY + CY) = D(1, XX + CX, YY + CY)
      ProcessedBits(2, XX + CX, YY + CY) = D(2, XX + CX, YY + CY)

      If tx >= 0 And ix + 1 < W Then
       If ty >= 0 And iy + 1 < H Then
           'если видно  = 1
           'прозрачно = 0
           TopLV = -CBool(P(0, ix, iy) <> TR Or P(1, ix, iy) <> TG Or P(2, ix, iy) <> TB) * Alpha
           TopRV = -CBool(P(0, ix + 1, iy) <> TR Or P(1, ix + 1, iy) <> TG Or P(2, ix + 1, iy) <> TB) * Alpha
           BotLV = -CBool(P(0, ix, iy + 1) <> TR Or P(1, ix, iy + 1) <> TG Or P(2, ix, iy + 1) <> TB) * Alpha
           BotRV = -CBool(P(0, ix + 1, iy + 1) <> TR Or P(1, ix + 1, iy + 1) <> TG Or P(2, ix + 1, iy + 1) <> TB) * Alpha
           
'среднее из 4
           TopL = (1 - dx) * (1 - dy)
           TopR = dx * (1 - dy)
           BotL = (1 - dx) * dy
           BotR = dx * dy
'         прозрачность
           ProcessedBits(0, XX + CX, YY + CY) = (P(0, ix, iy) * TopLV + D(0, XX + CX, YY + CY) * (1 - TopLV)) * TopL + (P(0, ix + 1, iy) * TopRV + D(0, XX + CX, YY + CY) * (1 - TopRV)) * TopR + (P(0, ix, iy + 1) * BotLV + D(0, XX + CX, YY + CY) * (1 - BotLV)) * BotL + (P(0, ix + 1, iy + 1) * BotRV + D(0, XX + CX, YY + CY) * (1 - BotRV)) * BotR
           ProcessedBits(1, XX + CX, YY + CY) = (P(1, ix, iy) * TopLV + D(1, XX + CX, YY + CY) * (1 - TopLV)) * TopL + (P(1, ix + 1, iy) * TopRV + D(1, XX + CX, YY + CY) * (1 - TopRV)) * TopR + (P(1, ix, iy + 1) * BotLV + D(1, XX + CX, YY + CY) * (1 - BotLV)) * BotL + (P(1, ix + 1, iy + 1) * BotRV + D(1, XX + CX, YY + CY) * (1 - BotRV)) * BotR
           ProcessedBits(2, XX + CX, YY + CY) = (P(2, ix, iy) * TopLV + D(2, XX + CX, YY + CY) * (1 - TopLV)) * TopL + (P(2, ix + 1, iy) * TopRV + D(2, XX + CX, YY + CY) * (1 - TopRV)) * TopR + (P(2, ix, iy + 1) * BotLV + D(2, XX + CX, YY + CY) * (1 - BotLV)) * BotL + (P(2, ix + 1, iy + 1) * BotRV + D(2, XX + CX, YY + CY) * (1 - BotRV)) * BotR
       End If
      End If
   Next
  Next
  StretchDIBits Destdc, x - Tmp / 2, y - Tmp / 2, Tmp, Tmp, 0, 0, Tmp, Tmp, ProcessedBits(0, 0, 0), BackBmp, DIB_RGB_COLORS, SRCCOPY
  Erase D
  Erase ProcessedBits
  Erase P
End Sub

Ответить

  Ответы Всего ответов: 10  

Номер ответа: 1
Автор ответа:
 Боцман



ICQ: 295725312 

Вопросов: 53
Ответов: 830
  Web-сайт: Rus-Skipper.narod.ru
 Профиль | | #1 		Добавлено: 29.03.08 21:39
Да просто на форме разместите Picture1 и на нем уже Picture2

Ответить

Номер ответа: 2
Автор ответа:
 



Администратор

ICQ: 278109632 

Вопросов: 42
Ответов: 3949
  Web-сайт: domkratt.com
 Профиль | | #2 		Добавлено: 30.03.08 10:55
Попробуй иногда хэндлы и дескрипторы устройств закрывать что ли....

Ответить

Номер ответа: 3
Автор ответа:
 Боцман



ICQ: 295725312 

Вопросов: 53
Ответов: 830
  Web-сайт: Rus-Skipper.narod.ru
 Профиль | | #3 		Добавлено: 31.03.08 20:52
Executioner
Выделение памяти здесь.
iBitmap = CreateDIBSection(BackDC, BackBmp, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&;)
в модуле в конце пробовал
  ;DeleteDC (Destdc)
  ;DeleteObject iBitmap
результат отрицательный.

Ответить

Номер ответа: 4
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #4 		Добавлено: 31.03.08 21:53
Почему закомментировано
'DeleteDC (PicDC)

Ответить

Номер ответа: 5
Автор ответа:
 Боцман



ICQ: 295725312 

Вопросов: 53
Ответов: 830
  Web-сайт: Rus-Skipper.narod.ru
 Профиль | | #5 		Добавлено: 31.03.08 22:37
Почему закомментировано
'DeleteDC (PicDC)

Да потому что нечего не меняет.
Добовлял в конце в модуль следуещие;
  Form1.Picture1.Refresh
  ;DeleteDC (Destdc)
    ;DeleteDC (Destdc)
    ;DeleteDC Form1.Picture2.hdc
End Sub

Ответить

Номер ответа: 6
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #6 		Добавлено: 01.04.08 00:41
Дано: Executioner прав.
Найти: Незакрытые хендлы
Решение:
DeleteDC BackDC
DeleteObject iBitmap
DeleteDC PicDC

Ответить

Номер ответа: 7
Автор ответа:
 Winand



Вопросов: 87
Ответов: 2795
  Web-сайт: winandfx.narod.ru
 Профиль | | #7 		Добавлено: 01.04.08 00:45
Destdc не создаешь в функции, зачем закрывать...

Ответить

Номер ответа: 8
Автор ответа:
 



Администратор

ICQ: 278109632 

Вопросов: 42
Ответов: 3949
  Web-сайт: domkratt.com
 Профиль | | #8 		Добавлено: 01.04.08 01:12
Объекты, кстати, тоже неплохо бы удалять.... Типа iBitmap и прочего. Хэндлы-то в винде конечные, не забывай =)

Ответить

Номер ответа: 9
Автор ответа:
 



Администратор

ICQ: 278109632 

Вопросов: 42
Ответов: 3949
  Web-сайт: domkratt.com
 Профиль | | #9 		Добавлено: 01.04.08 01:13
Ой.... не заметил у Winand'а в посте удаление iBitmap =) Прошу прощения.

Ответить

Номер ответа: 10
Автор ответа:
 Боцман



ICQ: 295725312 

Вопросов: 53
Ответов: 830
  Web-сайт: Rus-Skipper.narod.ru
 Профиль | | #10 		Добавлено: 01.04.08 07:32
Всем спасибо.

Ошибка была такая, я писал так;
DeleteObject iBitmap
DeleteDC PicDC
DeleteDC (Destdc)


пологая что DeleteObject iBitmap достаточно и пропустил DeleteDC BackDC. Такой код верен.
Form1.Picture1.Refresh
DeleteDC BackDC
DeleteObject iBitmap
DeleteDC PicDC

С 1 апреля заодно поздравляю Всех. Удачи и веселого настроения.

Ответить

Страница: 1 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам