мелкая проблемка с JPEG VB LoadPicture()

[eugene2005]

http://forum.sources.ru/index.php?showtopic=104211

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

hDesk = GetDesktopWindow()
hDeskDC = GetDC(hDesk)
BitBlt Picture2.hDC, 0, 0, Width, Height, hDeskDC, 0, 0, SRCCOPY

Dim MyPic As StdPicture
set MyPic = ..........

вот часть кода которая меня волнует, не пойму его.
если делаю savepicture а затем loadpicture в mypic то всё ок работает
а как можно перебросить быстрее без сохранения и загрузки в set mypic изображение picture2?

[keks-n]

BitBlt?

[BV]

Опять 25...

Picture2.Picture = Picture2.Image сразу после BitBlt

[eugene2005]

а что за выкрутасы делает этот .image i .picture

[eugene2005]

всё равно subscript out of range error 9
вот тут n = UBound(data) + 1

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


Private Sub CollectStatisticsDCInterleaved(data() As Integer, freqdc() As Long, Hi As Long, Vi As Long)

Dim p()       As Long
Dim f         As Long
Dim g         As Long
Dim h         As Long
Dim i         As Long
Dim j         As Long
Dim n         As Long
Dim s         As Long
Dim Diff      As Long
Dim Pred      As Long
Dim pLF       As Long
Dim MCUr      As Long
Dim MCUx      As Long
Dim MCUy      As Long



    n = UBound(data) + 1

    ReDim p(Vi - 1)
    MCUx = (XX + 8 * HMax - 1) \ (8 * HMax)
    MCUy = (YY + 8 * VMax - 1) \ (8 * VMax)
    h = (-Int(-XX * Hi / HMax) + 7) \ 8
    For g = 0 To Vi - 1
        p(g) = 64 * h * g
    Next g
    pLF = 64 * h * (Vi - 1)
    MCUr = (h Mod Hi)
    If MCUr = 0 Then MCUr = Hi
    For j = 1 To MCUy - 1
        For i = 1 To MCUx - 1
            For g = 1 To Vi
                For h = 1 To Hi
                    Diff = data(p(g - 1)) - Pred
                    Pred = data(p(g - 1))
                    p(g - 1) = p(g - 1) + 64
                    If Diff < 0 Then
                        s = Int((Log(-Diff) * 1.442695040889)) + 1
                        ElseIf Diff > 0 Then
                        s = Int((Log(Diff) * 1.442695040889)) + 1
                        Else
                        s = 0
                    End If
                    freqdc(s) = freqdc(s) + 1
                Next h

[eugene2005]

всё таки что то другое делает этот
SavePicture picture1.Image, "C:\porno.bmp" и
loadpicture

это никак не есть еквивалент picture1.picture= picture1.image

так ок
Set MyPic = LoadPicture(FileName)

а так ошибка
Set MyPic = picture1.picture

[BV]

Да неужели?

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

Option Explicit

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 GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long

Private Sub Form_Activate()
    Dim hDeskDC As Long
    Dim hMyPic As StdPicture
    hDeskDC = GetDC(0&)
    picCanvas.ScaleMode = vbPixels: picCanvas.AutoRedraw = True
    Call BitBlt(picCanvas.hDC, 0, 0, picCanvas.ScaleWidth, picCanvas.ScaleHeight, _
        hDeskDC, 0, 0, vbSrcCopy)
    picCanvas.Picture = picCanvas.Image
    Set hMyPic = picCanvas.Picture
    MsgBox "У нас всё работает с hMyPic: " & CBool(hMyPic)
End Sub

[eugene2005]

source http://forum.sources.ru/index.php?act=A ... &id=793185

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


Private m_Image     As New cImage
Private m_Jpeg      As New cJpeg



Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private 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

Private Const SRCCOPY = &HCC0020



Private Sub Command1_Click()

    Dim hDeskDC As Long
    Dim hMyPic As StdPicture
    hDeskDC = GetDC(0&)
    picCanvas.ScaleMode = vbPixels: picCanvas.AutoRedraw = True
    Call BitBlt(picCanvas.hDC, 0, 0, picCanvas.ScaleWidth, picCanvas.ScaleHeight, _
        hDeskDC, 0, 0, vbSrcCopy)
    picCanvas.Picture = picCanvas.Image


Set hMyPic = picCanvas.Picture

''''''''' вот c  этими функциями всё ок работает - без них труба
' что делает такого особенного этот LoadPicture()?
'SavePicture picCanvas.Image, App.Path & "\porno.bmp"
'Set hMyPic = LoadPicture(App.Path & "\porno.bmp")


Set m_Image = New cImage
m_Image.CopyStdPicture hMyPic

Set m_Jpeg = New cJpeg
m_Jpeg.SetSamplingFrequencies 2, 2, 1, 1, 1, 1
m_Jpeg.Quality = CLng(40)

' вот тут выдаёт ошибку subscript out of range, error 9.
' n = UBound(data) + 1 в Sub CollectStatisticsDCInterleaved(data() As Integer, freqdc() As Long, Hi As Long, Vi As Long)


'если загружать через LoadPicture() то сообщение покажет цифры ,
'если делать Set hMyPic = picCanvas.Picture то всё по нулям

MsgBox "m_Image.hDC=" & m_Image.hDC & " m_Image.Width=" & m_Image.Width & _
" m_Image.Height=" & m_Image.Height

m_Jpeg.SampleHDC m_Image.hDC, m_Image.Width, m_Image.Height

m_Jpeg.SaveFile App.Path & "\porno.jpg"



End Sub



[tyomitch]

Админы, поставьте плз лимит на размер поста
Меня ничуть не вставляет скачивать 300Кб кода, чтобы прочитать вопрос из десяти слов.

[eugene2005]

sorry, tyomich

[eugene2005]

детальный дебуг помог =)
bitblt делает глубину цвета как десктоп у меня 32 бита

iBitCount = 24

сорри за флейм