Воспоминания свой кодек на VB6, 15.05.2024

Germany.ru → Группы → Архив Досок→ Дневник тяжелобольного инвалида

857

uscheswoi_82 коренной житель15.05.24 05:51

15.05.24 05:51

Всем привет, в 2003 году я занимался созданием своего видеокодека, была мечта передавать видео через обычный 56k модем, который так и остался мечтой. Так-же была возможность проигрывать видео по сети. Видеоплеер выглядел вот так:

Вот сам код на VB6, для проигрывания видео файла, но я забыл уже что тут к чему, но алгоритм простой, читаешь сколько-то байтов из файла, получаешь код цвета, и отображаешь их спомощью SetPixelV:

Option Explicit
Public VideoSeting As Integer
Public videomem(350, 40000) As Long
Public pos(100000) As Long
Public wsz As Long
Public Type Images
    sRGB As Long
    cmd As Byte
End Type

Public Type fileInfo
    frameWidth As Long
    frameHeigh As Long
    framesCount As Long
End Type

Public Type sysInfo
    sysErr As Boolean
    sysFrame As Long
    sysPrevFrame As Long
    sysCache As Long
    sysFrameCant As Long
End Type

Public fileinf As fileInfo
Public sysinf As sysInfo
Public frame As Long

Public v As Long
Public cache As Long
Public img As Images
Public ToHdc As Long
Public ToPic As Form
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public 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 Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Public Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long

Private Sub Quadrat(ByVal x As Integer, ByVal y As Integer, ByVal sstep As Integer, ByVal clr As Long)
Dim n As Integer, m As Integer, sx As Single, sy As Single

If VideoSeting = 1 Then
    sx = 7 + (5.5 - Rnd * 9.5) + 2
Else
    sx = 1
GoTo STEP
End If
STEP:
    For n = 0 To sstep Step Round(sx)
        If n > frmVideo.Height Then Exit Sub
        For m = 0 To sstep Step 16
            SetPixelV ToHdc, x + m, y + n, clr
            SetPixelV ToHdc, x + m + 1, y + n, clr
            SetPixelV ToHdc, x + m + 2, y + n, clr
            SetPixelV ToHdc, x + m + 3, y + n, clr
            SetPixelV ToHdc, x + m + 4, y + n, clr
            SetPixelV ToHdc, x + m + 5, y + n, clr
            SetPixelV ToHdc, x + m + 6, y + n, clr
            SetPixelV ToHdc, x + m + 7, y + n, clr
            SetPixelV ToHdc, x + m + 8, y + n, clr
            SetPixelV ToHdc, x + m + 9, y + n, clr
            SetPixelV ToHdc, x + m + 10, y + n, clr
            SetPixelV ToHdc, x + m + 11, y + n, clr
            SetPixelV ToHdc, x + m + 12, y + n, clr
            SetPixelV ToHdc, x + m + 13, y + n, clr
            SetPixelV ToHdc, x + m + 14, y + n, clr
            SetPixelV ToHdc, x + m + 15, y + n, clr
        Next m
    Next n
End Sub


Public Sub Quadrat2(ByVal x As Long, ByVal y As Long, ByVal clr As Long)
    SetPixelV ToHdc, x, y, clr
    SetPixelV ToHdc, x + 1, y, clr
    
    SetPixelV ToHdc, x, y + 1, clr
    SetPixelV ToHdc, x + 1, y + 1, clr

    SetPixelV ToHdc, x + 2, y + 2, clr
    SetPixelV ToHdc, x + 3, y + 2, clr

    SetPixelV ToHdc, x + 2, y + 3, clr
    SetPixelV ToHdc, x + 3, y + 3, clr
End Sub

Public Sub AllReset()
frame = 0
v = 1
End Sub

Public Sub ShowFrame(tm As Timer)
Dim i As Long, j As Long, n As Long
cache = cache + 1
If cache >= 99 Then cache = 0
    For j = 0 To 600 Step 9
        For i = 0 To 600 Step 9
START:
            Get #1, v, img
            v = v + 1
            sysinf.sysCache = cache
            sysinf.sysFrame = frame + 1
            If img.cmd = 0 Then v = 1: tm.Enabled = False
            If img.sRGB > 200 Then videomem(cache, n) = img.sRGB
            SetPixelV ToHdc, i / 5, j / 5, videomem(cache, n)
            SetPixelV ToHdc, 1 + i / 5, j / 5, videomem(cache, n)
            SetPixelV ToHdc, i / 5, 1 + j / 5, videomem(cache, n)
            SetPixelV ToHdc, 1 + i / 5, 1 + j / 5, videomem(cache, n)


            SetPixelV ToHdc, 2 + i / 5, 2 + j / 5, videomem(cache, n)
            SetPixelV ToHdc, 3 + i / 5, 2 + j / 5, videomem(cache, n)
            SetPixelV ToHdc, 2 + i / 5, 3 + j / 5, videomem(cache, n)
            SetPixelV ToHdc, 3 + i / 5, 3 + j / 5, videomem(cache, n)
            n = n + 1
        Next i
    Next j
    On Error Resume Next
    pos(frame) = n + pos(frame - 1)
    frame = frame + 1
    pos(frame) = n + pos(frame - 1)
    frame = frame + 1
End Sub

Function CountFrames() As Long
Dim i As Long, j As Long, n As Long
Dim frm As Long
Dim ccc As Long
n = 1
Get #1, n, img
If img.cmd = 110 And img.sRGB = 1000 Then
    MsgBox "Данный кодек отсутствует:" & "IMG-PRO v2.5"
    frmMain.cmdPlay.Enabled = False
    Exit Function
End If
If img.cmd <> 100 Then
    MsgBox "Информация о количестве кадров найдена не была. После подсчёта будет сохранено количество кадров."
Else
    CountFrames = img.sRGB
    Exit Function
End If

Do While Not EOF(1)
    For j = 0 To 600 Step 9
        For i = 0 To 600 Step 9
            ccc = ccc + 1
            If ccc > 100000 Then ccc = 0: DoEvents
            Get #1, n, img
            n = n + 1
            Get #1, n, img
            n = n + 1
            Get #1, n, img
            n = n + 1
            Get #1, n, img
            n = n + 1
            Get #1, n, img
            n = n + 1
        Next i
    Next j
    pos(frm) = n / 5
    frm = frm + 2
    pos(frm) = n / 4
    frm = frm + 2
    pos(frm) = n / 3
    frm = frm + 2
    pos(frm) = n / 2
    frm = frm + 2
    pos(frm) = n
    frm = frm + 2
    frmMain.Label1.Caption = "Подсчет кадров:" & frm
Loop
Seek #1, 1
CountFrames = frm
img.cmd = 100
img.sRGB = frm
Put #1, 1, img
End Function

Public Sub DrawFrame(ByVal cache As Long)
Dim i As Long, j As Long, n As Long
    For j = 0 To 300 Step 9
        For i = 0 To 300 Step 9
            sysinf.sysCache = cache
            sysinf.sysFrame = frame
            Quadrat i, j, 9, videomem(cache, n)
            n = n + 1
        Next i
    Next j
frame = frame + 1
End Sub

Public Sub DrawFrame2(ByVal cache As Long)
Dim i As Long, j As Long, n As Long
    For j = 0 To 300 Step 9
        For i = 0 To 300 Step 9
            Quadrat i, j, 9, videomem(cache, n)
            n = n + 1
        Next i
    Next j
End Sub

Public Sub Sleep()
Dim j As Long, i As Long, n As Long
    For i = 0 To 1000
        For j = 0 To 100
            For n = 0 To 10
                Sin 3
            Next n
        Next j
    Next i
End Sub

Результат работы программы, т.е. проигрывание видео:

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

Дневник тяжелобольного инвалида

uscheswoi_82 коренной житель15.05.24 05:56

NEW 15.05.24 05:56

в ответ uscheswoi_82 15.05.24 05:51

Выше я показал новый видео проигрыватель, а старый видео проигрыватель назывался ВидеоФон, т.к. я хотел видео пересылать спомощью модема 56k по телефоной линии. Вот серверная программа, которая может находится удалённо на сервере:

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

Дневник тяжелобольного инвалида

uscheswoi_82 коренной житель15.05.24 23:00

NEW 15.05.24 23:00

в ответ uscheswoi_82 15.05.24 05:56

Я в своём кодеке использовал функцию SetPixelV, потому-что эта функция самая быстрая.

Проведём небольшой эксперимент, вот код Form1.frm:

Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) 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 Form_Click()
    Dim s As String
    Dim dt As Date, dt2 As Date
    Dim v As Long, x As Long, y As Long
    Dim r As Integer, g As Integer, b As Integer
    
    Me.Cls
    dt = Now
    For y = 0 To Me.ScaleHeight
        For x = 0 To Me.ScaleWidth
            r = Int(Rnd * 255)
            g = Int(Rnd * 255)
            b = Int(Rnd * 255)
            Me.PSet (x, y), RGB(r, g, b)
            DoEvents
        Next x
    Next y
    
    dt2 = Now
    v = DateDiff("s", dt, dt2)
    s = s + "PSET " + CStr(v)
    Me.Caption = s
    
    Me.Cls
    dt = Now
    For y = 0 To Me.ScaleHeight
        For x = 0 To Me.ScaleWidth
            r = Int(Rnd * 255)
            g = Int(Rnd * 255)
            b = Int(Rnd * 255)
            SetPixel Me.hdc, x, y, RGB(r, g, b)
            DoEvents
        Next x
    Next y
    
    dt2 = Now
    v = DateDiff("s", dt, dt2)
    s = s + ", SETPIXEL " + CStr(v)
    Me.Caption = s
    
    Me.Cls
    dt = Now
    For y = 0 To Me.ScaleHeight
        For x = 0 To Me.ScaleWidth
            r = Int(Rnd * 255)
            g = Int(Rnd * 255)
            b = Int(Rnd * 255)
            SetPixelV Me.hdc, x, y, RGB(r, g, b)
            DoEvents
        Next x
    Next y
    
    dt2 = Now
    v = DateDiff("s", dt, dt2)
    s = s + ", SETPIXELV " + CStr(v)
    Me.Caption = s
    
    Me.Picture1.Visible = True
    Me.Cls
    dt = Now
    For y = 0 To Me.ScaleHeight
        For x = 0 To Me.ScaleWidth
            r = Int(Rnd * 255)
            g = Int(Rnd * 255)
            b = Int(Rnd * 255)
            Me.Picture1.BackColor = RGB(r, g, b)
            BitBlt Me.hdc, x, y, 1, 1, Me.Picture1.hdc, 0, 0, SRCCOPY
            DoEvents
        Next x
    Next y
    
    dt2 = Now
    v = DateDiff("s", dt, dt2)
    s = s + ", BITBLT " + CStr(v)
    Me.Caption = s
End Sub

Private Sub Form_Load()
    Me.Picture1.Width = 1
    Me.Picture1.Height = 1
    Me.Picture1.Visible = False
    Me.WindowState = vbMaximized
End Sub

Результаты 1980x1080, pset 21 сек., SetPixel 11 сек., SetPixelV 10 сек., BitBlt 44 сек.:

Анимация, работа теста, 640x480, результат Pset 4, SetPixel 2, SetPixelV 2, BitBlt 9:

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

Дневник тяжелобольного инвалида

uscheswoi_82 коренной житель16.05.24 21:15

NEW 16.05.24 21:15

в ответ uscheswoi_82 15.05.24 23:00

К чему был этот тест?

Дело в том, что в Visual Basic-е есть встроенная функция Pset, она медленная, поэтому если делаешь видеокодек надо использовать Windows функции SetPixel или SetPixelV, но SetPixelV быстрее чем SetPixel. BitBlt нужно там, где нужно масштабировать, BitBlt очень медленная функция.

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

Дневник тяжелобольного инвалида

uscheswoi_82 коренной житель16.05.24 21:30

NEW 16.05.24 21:30

в ответ uscheswoi_82 16.05.24 21:15

В качестве интерфейса для моего видеопроигрывателя, я взял за основу ActiveMovie, RealPlayer и Windows Media Player:

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

Дневник тяжелобольного инвалида

uscheswoi_82 коренной житель16.05.24 22:13

NEW 16.05.24 22:13

в ответ uscheswoi_82 16.05.24 21:30

Чтобы передавать изображение по телефонной линии или по сети, есть в Visual Basic 6.0 два элемента MSComm и WinSock. Вот они:

А это настройки модема (MSComm) и сети (WinSock):

Если я кому-то отвечаю, это не значит что я ему симпатизирую, каждый остаётся при своём мнение

Дневник тяжелобольного инвалида

список вперед