Сохранить в битмэп

[Ariman]

Возник такой вопрос:
Предположим, есть некоторый hDC..... Даже скажем конкретнее, не какой-то hDC, а вполне конкретный Picture. В него динамически рисуется картинка (Битблитится фон, спрайты и т.д.)
Есть ли возможность сохранить содержимое, не пробегая в цикле все пиксели? Очень скорость критична - нужно как можно быстрее сохранять...........

Суть проблемы - есть игра(GW, если кто еще не догадался ),
хочется сделать возможность записи матча, чтобы потом просматривать. У кого есть другие варианты - предлагайте!
Пока у меня только два варианта:
первый - брать hDC того места ( ) куда рисуется уже собранный "экран"(кривовато выразился, но, думаю, понятно, о чем речь) и сохранить его в файл..... Конечно, в идеале - AVI, но для начала хоть JPG........
Второй вариант пока излагать не стану, чтобы не сбить с толку тех, кто врдуг соберется помочь

[FaKk2]

Код: Выделить всё

SavePicture Picture.Image, "c:\test.bmp"

[Ariman]

FAKK2
Ну конечно
Ты хоть сам-то пробовал? Или это я неправильно делаю???
Попробуй поставить пиксель с помощью pset, или битблить что-нибудь туда! А потом сохрани...... Лично у меня никакого результата!
Иначе бы и спрашивать про такое не стал.
Тут надо как-то хитрее......

[_Мика_]

Это в модуль.....там есть кое что лишнее....потом уберешь

Код: Выделить всё

   Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
   Public Const HWND_TOPMOST = -1
   Public Const HWND_NOTOPMOST = -2
   Public Const SWP_NOMOVE = &H2
   Public Const SWP_NOSIZE = &H1
   Public Const SWP_NOACTIVATE = &H10
   Public Const SWP_SHOWWINDOW = &H40
   Declare Function ReleaseCapture Lib "user32" () As Long
   Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
   Public Const HTCAPTION = 2
   Public Const WM_NCLBUTTONDOWN = &HA1
   Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32" (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
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Sub MoveForm(ByVal qHwnd As Long)
    ReleaseCapture
    SendMessage qHwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

Sub OnTop(ByVal aHwnd As Long)
SetWindowPos aHwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

Sub NoOnTop(ByVal zHwnd As Long)
SetWindowPos zHwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

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

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
        .Size = Len(Pic) ' Length of structure
        .Type = vbPicTypeBitmap ' Type of Picture (bitmap)
        .hBmp = hBmp ' Handle to bitmap
        .hPal = hPal ' Handle to palette (may be null)
    End With

    'Create the picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

    'Return the new picture
    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
    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
    Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

    'Create a compatible device context
    hDCMemory = CreateCompatibleDC(hDCSrc)
    'Create a compatible bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    'Select the compatible bitmap into our compatible device context
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    'Raster capabilities?
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
    'Does our picture use a palette?
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    'What's the size of that palette?
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Set the palette version
        LogPal.palVersion = &H300
        'Number of palette entries
        LogPal.palNumEntries = 256
        'Retrieve the system palette entries
        R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        'Create the palette
        hPal = CreatePalette(LogPal)
        'Select the palette
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        'Realize the palette
        R = RealizePalette(hDCMemory)
    End If

    'Copy the source image to our compatible device context
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    'Restore the old bitmap
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'Select the palette
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    'Delete our memory DC
    R = DeleteDC(hDCMemory)

    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function



А это в форму

Код: Выделить всё

Set Picture2.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / 15, Screen.Height / 15)

SavePicture Picture2.Picture, "C:\Pic001.bmp"


[Ariman]

Ох, прошу прощения.... Все работает, это я был неправ....
Тогда другой вопрос: сохранять так весь матч - это самоубийство! Ведь на выходе даже несжатые БМП!
Есть еще предложения?

[_Мика_]

Сохранять их в JPG, а потом компоновать в .AVI

[Ariman]

Вопрос в том, чтобы на выходе получить AVI(в идеале), или хотя бы хорошо сжатые JPGи! А то каждый такой кадр по 1.5 МБ - куда это годиться?

[Ariman]

Сохранять их в JPG

Ну о том и речь! Как это сделать? SavePicture только в БМП сохраняет.

[_Мика_]

Тогда только GDI+

М вот кода как его использовать

Код: Выделить всё

CreateBitmapFromPicture(Picture2.Picture).SaveToJpeg "C:\Pic001.jpg", <<значение от 0 до 100 (качество)>>


[FaKk2]

Ariman

Я не знаю, чем ты сохраняешь, но у меня тоже блититтся, и сохраняется на ура иначе бы не давал кода.

[Ariman]

_Мика_

А скорость как? А то я вот попробовал SavePicture (стандартную ВБшную функцию), так скорость

[Ariman]

FAKK2
Я же уже сказал:

Ох, прошу прощения.... Все работает, это я был неправ....

[FaKk2]

Ariman
Ты не адресовал мне

[Ariman]

Так что, у кого-нибудь есть предложения, как осуществить запись матча, чтобы это не сильно повлияло на скорость?

[Amed]

Код: Выделить всё

Picture1.Picture=Picture1.Image
SavePicture Picture1.Picture, "..."

Это для сохранения наблиттенного...