Как сохранить картинку в файл BMP или байтовый массив из Picture1.hdc

@HackerVlad · Регистрация: 10.09.2021

Студворк — интернет-сервис помощи студентам

Как сохранить картинку в файл BMP или байтовый массив из Picture1.hdc

Может быть уже есть такая удобная функция, которая бы принимала в качестве параметра Picture1.hdc и/или Picture1.Image.handle и сохраняла бы картинку, не в битовую карту, а именно в файл BMP со всеми заголовками BMP.

Мне просто интересно, так сказать исходный код для сохранения картинки в BMP. Я сегодня кое что нашёл в Интернете для этих целей, но этого не достаточно.

Добавлено через 7 минут
Вот тут интересно очень почитать можно: https://moddb.fandom.com/wiki/... nformation

Добавлено через 11 минут
Вообще я знаю как очень легко сохранить Picture, но мне хотелось бы сохранить не Picture, а то что находится в hdc
Именно в файл!!! А не в битовую карту через GetDIBits.

@HackerVlad · 23.01.2025, 02:12 **[ТС]**

Я создал идеальный проект. Под названием "Как сохранить картинку в файл BMP или байтовый массив из HBITMAP".
Я написал модуль который сохраняет любую картинку в байтовый массив BMP, при этом байтовый массив BMP компонуется вручную, файл BMP создаётся практически с нуля! Своим собственным кодом! Плюс ко всему прочему, в моём модуле, в моей функции SavePictureAsBitmap имеется возможность конвертировать картинку в различные биты: 1, 4, 8, 16, 24 и даже 32 бита!!! Что немаловажно кстати, если картинка была изначально загружена со всеми прозрачностями (32 бита) - то она со всеми прозрачностями и остаётся, и сохраняется с поддержкой альфа-канала даже. Что немаловажно тоже кстати. Альфа-канальное сохранение протестируйте сами уже, если хотите. В приложенном проекте-примере идёт работа с простыми картинками только. Надеюсь, этот код будет работать даже в Windows 95

Код идеальнейшего модуля (старался 3 дня писал):

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
Option Explicit
'//////////////////////////////////////////////////////////
'// Модуль для сохранения BMP-картинок в байтовый массив //
'// Copyright (c) 22.01.2025 by HackerVlad               //
'// e-mail: vladislavpeshkov@ya.ru                       //
'// Версия 1.0                                           //
'//////////////////////////////////////////////////////////
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hbm As Long, ByVal nStartScan As Long, ByVal cLines As Long, lpvBits As Any, lpbmi As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
 
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private 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
 
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(255) As Long
End Type
 
Private Type BITMAP
    bmType As Long
    bmWidth As Long ' the width of the bitmap
    bmHeight As Long ' the height of the bitmap
    bmWidthBytes As Long    ' the number of bytes needed to store 1 scanline.
                            ' = bmwidth*(bmBitsPixel/8)+padding bytes (if needed)
    bmPlanes As Integer
    bmBitsPixel As Integer ' the number of bits needed to store the color value of 1 pixel
    bmBits As Long
End Type
 
Public Enum SetBPP
    NoConvert = 0 ' Save the current picture bitrate
    ConvertTo1bpp = 1 ' 2 colors
    ConvertTo4bpp = 4 ' 16 colors
    ConvertTo8bpp = 8 ' 256 colors
    ConvertTo16bpp = 16
    ConvertTo24bpp = 24
    ConvertTo32bpp = 32
End Enum
 
' hBitmap is an StdPicture, that is, it can be, for example, Picture1.Picture or Picture1.Image or Image1.Picture
Public Function SavePictureAsBitmap(ByVal hBitmap As Long, BmpFileData() As Byte, Optional ByVal BitsPerPixel As SetBPP) As Boolean
    Dim WidthArray As Long, hdc As Long, ret As Long, ret2 As Long
    Dim bpp As Integer, i As Integer
    Dim FileHeader As BITMAPFILEHEADER
    Dim bInfo As BITMAPINFO
    Dim hBmp As BITMAP
    Dim nCol As Byte
    Dim Palette() As Long
    Dim bArray() As Byte
    
    ' Acceptable BitsPerPixel values: 0 (leave the image without bpp changes), 1 (2 colors), 4 (16 colors), 8 (256 colors), 16, 24, 32
    If BitsPerPixel <> 0 And BitsPerPixel <> 1 And BitsPerPixel <> 4 And BitsPerPixel <> 8 And BitsPerPixel <> 16 And BitsPerPixel <> 24 And BitsPerPixel <> 32 Then Exit Function
    bpp = BitsPerPixel
    
    GetObject hBitmap, LenB(hBmp), hBmp ' We get all the necessary information about the image
    
    If bpp = 0 Then
        bpp = hBmp.bmBitsPixel ' Set the default bits per pixel value for the image
    End If
    
    bInfo.bmiHeader.biHeight = hBmp.bmHeight
    bInfo.bmiHeader.biWidth = hBmp.bmWidth
    bInfo.bmiHeader.biPlanes = hBmp.bmPlanes
    bInfo.bmiHeader.biBitCount = bpp
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    
    hdc = GetDC(0) ' We are cheating a little by using the default monitor hDC here
    ret = GetDIBits(hdc, hBitmap, 0, hBmp.bmHeight, ByVal 0&, bInfo, DIB_RGB_COLORS)
    ReleaseDC 0, hdc
    
    If ret Then
        WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
        ReDim bArray((WidthArray * bInfo.bmiHeader.biHeight) - 1)
        
        hdc = GetDC(0) ' We are cheating a little by using the default monitor hDC here
        ret2 = GetDIBits(hdc, hBitmap, 0, hBmp.bmHeight, bArray(0), bInfo, DIB_RGB_COLORS)
        ReleaseDC 0, hdc
        
        If ret2 Then
            Select Case bpp
                Case 1
                    bInfo.bmiHeader.biClrUsed = 2
                    bInfo.bmiHeader.biClrImportant = 2
                    bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
                    nCol = 1
                Case 4
                    bInfo.bmiHeader.biClrUsed = 16
                    bInfo.bmiHeader.biClrImportant = 16
                    bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
                    nCol = 15
                Case 8
                    bInfo.bmiHeader.biClrUsed = 256
                    bInfo.bmiHeader.biClrImportant = 256
                    bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
                    nCol = 255
                Case 16, 24, 32
                    nCol = 0
            End Select
            
            If nCol > 0 Then ' If a palette is needed
                ReDim Palette(nCol)
                
                For i = 0 To nCol
                    Palette(i) = bInfo.bmiColors(i)
                Next
            End If
            
            FileHeader.bfType = &H4D42 ' BM
            FileHeader.bfOffBits = Len(FileHeader) + Len(bInfo.bmiHeader) + IIf(nCol, (nCol + 1) * 4, 0) ' + palette, if needed
            FileHeader.bfSize = Len(FileHeader) + Len(bInfo.bmiHeader) + IIf(nCol, (nCol + 1) * 4, 0) ' + palette, if needed
            FileHeader.bfSize = FileHeader.bfSize + UBound(bArray) + 1
            
            ReDim BmpFileData(FileHeader.bfSize - 1) ' Allocate memory for a BMP file array
            
            ' We collect a BMP file from various structures
            CopyMemory BmpFileData(0), VarPtr(FileHeader.bfType), 2 ' Write FileHeader (stage 1)
            CopyMemory BmpFileData(2), VarPtr(FileHeader.bfSize), Len(FileHeader) - 2 ' Write FileHeader (stage 2)
            CopyMemory BmpFileData(Len(FileHeader)), VarPtr(bInfo.bmiHeader), Len(bInfo.bmiHeader) ' Write BitmapInfoHeader
            If nCol > 0 Then ' If a palette is needed
                CopyMemory BmpFileData(Len(FileHeader) + Len(bInfo.bmiHeader)), VarPtr(Palette(0)), (nCol + 1) * 4 ' Write Palette
            End If
            CopyMemory BmpFileData(FileHeader.bfOffBits), VarPtr(bArray(0)), UBound(bArray) + 1 ' Write an array of a bitmap
            
            SavePictureAsBitmap = True
        End If
    End If
End Function

Код формы (тестовая программа):

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Option Explicit
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
 
' 1 мини-функция преобразовать картинку в байтовый массив (Windows 95+)
' Всегда преобразовывает в BMP только в EXE, в IDE если картинка изначально была JPG то массив байт тоже будет JPG...
' Поэтому чтобы картинка была и в IDE тоже в байтовом массиве в BMP то нужно изначально загрузить BMP
Public Function SimpleSavePicture(pPic As StdPicture) As Byte()
    Dim PB As PropertyBag
    Set PB = New PropertyBag
    PB.WriteProperty "Pic", pPic
    SimpleSavePicture = MidB(PB.Contents, 51)
End Function
 
' 2 мини-функция преобразовать обратно байтовый массив в картинку (Windows Vista+)
' По быстрому преобразовать байтовый массив в пикчу (мини-аналог OleLoadPicture)
' Поддерживает очень многие форматы изображений (PNG, TIFF, BMP, GIF, JPG)
Public Function SimpleLoadPicture(bPic() As Byte) As StdPicture
    With CreateObject("WIA.Vector")
        .BinaryData = bPic
        Set SimpleLoadPicture = .Picture
    End With
End Function
 
Private Sub Command1_Click()
    ' test vb6 function
    SavePicture Picture1.Image, App.Path & "\test_vb6.bmp"
    
    ' test1
    Dim bArray() As Byte
    Dim FileNo As Integer
    
    SavePictureAsBitmap Picture1.Image, bArray, ConvertTo24bpp
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\test1.bmp"
    Open App.Path & "\test1.bmp" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
    
    Picture2.Picture = Picture1.Image ' Финтиплюха ;)
End Sub
 
Private Sub Command2_Click()
    ' test vb6 function
    SavePicture Picture1.Image, App.Path & "\test_vb6.bmp"
    
    ' test2
    Dim bArray() As Byte
    Dim FileNo As Integer
    
    bArray = SimpleSavePicture(Picture1.Image)
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\test2.bmp"
    Open App.Path & "\test2.bmp" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
End Sub
 
Private Sub Command3_Click()
    ' test vb6 function
    SavePicture Picture1.Picture, App.Path & "\test_vb6.bmp"
    
    ' test3
    Dim bArray() As Byte
    Dim FileNo As Integer
    
    SavePictureAsBitmap Picture1.Picture, bArray ' Auto-detect bpp
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\test3.bmp"
    Open App.Path & "\test3.bmp" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
End Sub
 
Private Sub Command4_Click()
    ' test vb6 function
    SavePicture Me.Picture, App.Path & "\test_vb6.bmp"
    
    ' test4
    Dim bArray() As Byte
    Dim FileNo As Integer
    
    SavePictureAsBitmap Me.Picture, bArray ' Auto-detect bpp
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\test4.bmp"
    Open App.Path & "\test4.bmp" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
    
    ' На выходе получаем два одинаковых файла - test_vb6.bmp и test4.bmp
End Sub
 
Private Sub Command5_Click()
    ' test vb6 function
    SavePicture Me.Picture, App.Path & "\test_vb6.bmp"
    
    ' test5
    Dim bArray() As Byte
    Dim FileNo As Integer
    
    bArray = SimpleSavePicture(Me.Picture) ' PropertyBag technology
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\test5.bmp"
    Open App.Path & "\test5.bmp" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
    
    ' На выходе получаем два совершенно разных файла в IDE (глюк Microsoft, в twinBASIC работает нормально в IDE)
    ' В IDE VB6 в итоге получаем в файле test5.bmp картинку JPG почему-то (изначально загружали JPG)...
    ' В EXE работает нормально везде и сохраняет в BMP как и положено, очень странное поведение...
End Sub
 
Private Sub Command6_Click()
    ' test6
    Dim bArray() As Byte
    Dim FileNo As Integer
    
    SavePictureAsBitmap Me.Picture, bArray, ConvertTo8bpp ' Преобразовать картинку в 256 цветов
    
    FileNo = FreeFile
    On Error Resume Next: Kill App.Path & "\test6.bmp"
    Open App.Path & "\test6.bmp" For Binary As FileNo
        Put #FileNo, , bArray
    Close FileNo
    
    Picture2.Picture = SimpleLoadPicture(bArray)
End Sub
 
Private Sub Form_Load()
    Ellipse Picture1.hdc, 25, 25, 250, 250
End Sub

@testuser2 · 23.01.2025, 07:22

Сообщение от HackerVlad

Я создал идеальный проект.

Не идеальный, ты у CopyMemory сделал второй параметр ByVal, чтобы потом везде писать глупый лишний VarPtr. Ты специально так о_О?

@Argus19 · 23.01.2025, 09:23

В каком виде изображение хранится в файле ресурсов?

@HackerVlad · 23.01.2025, 12:00 **[ТС]**

Argus19, в любом, хоть в PNG если сами туда запихнёте так

Добавлено через 7 минут

Сообщение от testuser2

Ты специально так о_О?

Нашёл к чему прицепиться)
Да, специально так.

Смотри там идёт

Visual Basic
1
VarPtr(FileHeader.bfType)

и

Visual Basic
1
VarPtr(FileHeader.bfSize)

разве они могут работать без VarPtr?

Добавлено через 1 минуту
я не проверял, может и может работать без VarPtr...

Добавлено через 3 минуты

Сообщение от testuser2

чтобы потом везде писать глупый лишний VarPtr.

Я просто подумал что без VarPtr это невозможно будет написать, я не проверял правда обратного, поэтому хз

Добавлено через 55 секунд

Сообщение от testuser2

Не идеальный

Поверь, для меня он - идеальный. Даже если кто-то скажет что Г...

Добавлено через 22 минуты
testuser2, проверь пожалуйста в VBA кнопку Test5 интересно будет ли там такой же глюк как в VB6 IDE, что функция SimpleSavePicture(Me.Picture) получает массив байт JPG, а не BMP как надо...

Добавлено через 1 минуту
Просто технология сохранения картинки с использованием PropertyBag - это такое чудо, что в IDE работает так, а в EXE по другому в VB6...

Добавлено через 2 минуты
Я думал может из-за надстройки PNGVB6 от The Trick'а происходит такое чудо, но вроде отключена эта надстройка и всё равно такое глючное поведение в VB6, при чём проверял в двух разных Windows - в XP и в 7

@testuser2 · 23.01.2025, 12:18

Сообщение от HackerVlad

я не проверял, может и может работать без VarPtr...

Нет, если не знаешь, тогда норм., но меня слегка раздражает, когда человек, допустим, знает все от п.. до крышки, но почему-то пишет чего-то лишнего. VarPtr это же как-бы функция (по всем признакам), но когда аргумент можно передать ByRef, то можно не вызывать дополнительную функцию, поскольку ByRef передается именно указатель на переменную, тот, который возвращает VarPtr. Мене нравится такое понятие как "чистый код", когда в коде меньше всего лишнего, по моему даже книжка про это есть, но я не читал.

@HackerVlad · 23.01.2025, 12:22 **[ТС]**

Сообщение от testuser2

знает все от п.. до крышки

С чего ты взял что я всё знаю? Я самоучка. Я не учился в колледже или в университете. Всё что я знаю это то что я узнал сам через Интернет и всё, я мало что знаю.

@testuser2 · 23.01.2025, 12:22

Потом, вот это объявление CopyMemory

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

оно как бы каноничное - два аргуента ByRef. Я в основном везде вижу такое объявления, и оно же в Апи-вьювере, и в WinDevLib от fafo. И когда я вижу другое объявление, то это как бы раздражает, я считаю, надо писать как все, не отбиваться от общего стада, т.ск.

@HackerVlad · 23.01.2025, 12:22 **[ТС]**

Считай, что The trick меня обучал программировать здесь вообще... До знакомства с The trick я в API вообще мало что понимал, только готовым кодом пользовался...

@HackerVlad · 23.01.2025, 12:28 **[ТС]**

Сообщение от testuser2

И когда я вижу другое объявление, то это как бы раздражает

Если я переписываю декларацию - не надо раздражаться, значит мне так просто удобнее.
Если я использую VarPtr значит на то есть причина.
Мне лучше один раз изменить декларацию, чем потом 100 раз переписывать на ByVal VarPtr
А так 1 раз изменил декларацию и всё и больше не надо писать по 100 раз лишние слова ByVal... Неужели ты этого не понимаешь!? Вроде бы умный парень же...

Добавлено через 2 минуты
Нашёл к чему придраться конечно
Лишь бы докопаться до чего-то

@testuser2 · 23.01.2025, 13:25

Сообщение от HackerVlad

Мне лучше один раз изменить декларацию, чем потом 100 раз переписывать на ByVal VarPtr

Тут есть такой момент. Когда ты делаешь какой-то проект, то логичнее и проще иметь одну декларацию, а не копипастить эту декларацию, допустим, в каждый модуль. Но если ты возьмешь в свой проект какой-то код, написанный под другой вид декларации, то тебе придется дополнительно добавлять декларации или переписывать этот код, притом эти добавленные декларации могут конфликтовать с твоими другими декларациями, в общем какие-то проблеммы. А когда все используют один и тот же вид деклараций, то это все проще, как бы стандартизация.

Добавлено через 8 минут

Сообщение от HackerVlad

проверь пожалуйста в VBA кнопку Test5

В VBA не доступен такой класс как PorpertyBag

Добавлено через 23 минуты

Сообщение от HackerVlad

Нашёл к чему придраться

Это не столько придирки, сколько желание передать определенную мысль. Вообще это можно было бы вынести в отдельную тему. Допустим в языке Си ест определенные общепринятые соглашения, что допустим переменные пишутся так, константы так и т.д. Предположим, если бы язык VB Classic был бы на столько же мега-популярным и распространенным как Си, то сообщесту также стоило бы выработать некоторые соглашения. Допустим такое, что не стоит менять общепринятые декларации, а если меняешь, то измени название функции, во избежания будущих непонятных ситуаций и т.д.

@HackerVlad · 23.01.2025, 14:01 **[ТС]**

testuser2, ты хотябы пробовал без VarPtr обойтись? прежде чем кричать что он не нужен.

Добавлено через 2 минуты

Сообщение от testuser2

В VBA не доступен такой класс как PorpertyBag

Хорошо, спасибо, понял. А в vb6 в IDE у тебя такой же глюк, как у меня? В пятом тесте?

@testuser2 · 23.01.2025, 16:53

Сообщение от HackerVlad

А в vb6 в IDE у тебя такой же глюк, как у меня?

Конечно будет также, можно не проверять

Сообщение от HackerVlad

ты хотябы пробовал без VarPtr обойтись? прежде чем кричать что он не нужен.

Имхо он замусоривает код, слегонца так, я бы сказал, лучше его по возможности избегать

@HackerVlad · 23.01.2025, 16:59 **[ТС]**

Сообщение от testuser2

по возможности

а есть ли такая вообще возможность в моём коде обойтись без VarPtr? Ты вообще проверял возможно ли это?

Добавлено через 46 секунд
VarPtr - это идеальность, которая позволяет нам работать со смещениями в структурах для CopyMemory

Добавлено через 36 секунд

Сообщение от testuser2

Конечно будет также

А вдруг не так же. Я же не просто так прошу. Вдруг только у меня так, а у тебя не так.

Добавлено через 19 секунд
testuser2, проверь, пожалуйста, если не лень.

Добавлено через 29 секунд
testuser2, тем более у тебя другая система Windows 8, у тебя и по другому может быть

@testuser2 · 23.01.2025, 17:06

Сообщение от HackerVlad

проверь, пожалуйста, если не лень.

Буквально нет сил, только силы есть сказать что-то мудрое, может быть, концептуальное относительно чего-то общего и отойти уже ко сну..

@HackerVlad · 24.01.2025, 17:21 **[ТС]**

testuser2, ну что там с тестом? или сегодня опять нет сил?

@testuser2 · 25.01.2025, 04:40

HackerVlad, точно также у меня, такое же поведение

@Mikle Quits · 25.01.2025, 08:52

Сообщение от HackerVlad

Если я переписываю декларацию - не надо раздражаться, значит мне так просто удобнее.
Если я использую VarPtr значит на то есть причина.

Уточни, какая причина. Потроллить?

Сообщение от HackerVlad

Мне лучше один раз изменить декларацию, чем потом 100 раз переписывать на ByVal VarPtr
А так 1 раз изменил декларацию и всё и больше не надо писать по 100 раз лишние слова ByVal

Это не причина, тебе не нужно писать лишнее ByVal, наоборот, теперь не нужно писать лишнее VarPtr(). А VarPtr() - это не просто удлиннение кода, это ещё и накладные расходы на вызов самой функции VarPtr() из своей DLL.

Сообщение от HackerVlad

VarPtr - это идеальность, которая позволяет нам работать со смещениями в структурах для CopyMemory

В приведённом коде вычисление адреса ни разу не использовалось. А, если бы даже использовалось - действительно, не сложно один раз написать ByVal VarPtr().
Кроме того, если бы ты действительно пользовался этой декларацией в других программах, где требуется вычисление адреса, и поэтому она так написана, то в ней бы и Destination тоже должен был быть ByVal, а то какая-то странная избирательность.
И ещё, ByVal Source As Long выглядит очень неоднозначно, легко можно подумать, что Source имеет тип Long и передаётся ByVal, должно было быть как-то типа ByVal pSource As Long.

@HackerVlad · 25.01.2025, 13:00 **[ТС]**

Умники тут меня осуждают вместо того чтобы предоставить свою версию кода. Перепишите. Покажите как лучше.

Добавлено через 1 минуту
Как хочу так и декларирую.

@The trick · 25.01.2025, 13:22

Не по теме:

Сообщение от Mikle Quits

Уточни, какая причина.

С большой вероятностью копипаста кода с непониманием как на самом деле это работает.

Сообщение от HackerVlad

Как хочу так и декларирую.

Спокойнее. Люди в свою очередь как хотят так и оценивают, не так ли? Мне вообще кажется что этот код был выдернут откуда-то и немного дополнен. Зачем 2 раза делать GetDC?

@HackerVlad · 25.01.2025, 16:59 **[ТС]**

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
Option Explicit
'//////////////////////////////////////////////////////////
'// Модуль для сохранения картинок в байтовый массив BMP //
'// Copyright (c) 25.01.2025 by HackerVlad               //
'// e-mail: vladislavpeshkov@ya.ru                       //
'// Версия 1.1                                           //
'//////////////////////////////////////////////////////////
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hbm As Long, ByVal nStartScan As Long, ByVal cLines As Long, lpvBits As Any, lpbmi As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
 
Private Type BITMAPFILEHEADER
    bfType As Integer
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type
 
Private 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
 
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors(255) As Long
End Type
 
Private Type BITMAP
    bmType As Long
    bmWidth As Long ' the width of the bitmap
    bmHeight As Long ' the height of the bitmap
    bmWidthBytes As Long    ' the number of bytes needed to store 1 scanline.
                            ' = bmwidth*(bmBitsPixel/8)+padding bytes (if needed)
    bmPlanes As Integer
    bmBitsPixel As Integer ' the number of bits needed to store the color value of 1 pixel
    bmBits As Long
End Type
 
Public Enum SetBPP
    NoConvert = 0 ' Save the current picture bitrate
    ConvertTo1bpp = 1 ' 2 colors
    ConvertTo4bpp = 4 ' 16 colors
    ConvertTo8bpp = 8 ' 256 colors
    ConvertTo16bpp = 16
    ConvertTo24bpp = 24
    ConvertTo32bpp = 32
End Enum
 
' hBitmap is an StdPicture, that is, it can be, for example, Picture1.Picture or Picture1.Image or Image1.Picture
Public Function SavePictureAsBitmap(ByVal hBitmap As Long, BmpFileData() As Byte, Optional ByVal BitsPerPixel As SetBPP) As Boolean
    Dim WidthArray As Long, hdc As Long, ret As Long, ret2 As Long
    Dim bpp As Integer, i As Integer
    Dim FileHeader As BITMAPFILEHEADER
    Dim bInfo As BITMAPINFO
    Dim hBmp As BITMAP
    Dim nCol As Byte
    Dim Palette() As Long
    Dim bArray() As Byte
    
    ' Acceptable BitsPerPixel values: 0 (leave the image without bpp changes), 1 (2 colors), 4 (16 colors), 8 (256 colors), 16, 24, 32
    If BitsPerPixel <> 0 And BitsPerPixel <> 1 And BitsPerPixel <> 4 And BitsPerPixel <> 8 And BitsPerPixel <> 16 And BitsPerPixel <> 24 And BitsPerPixel <> 32 Then Exit Function
    bpp = BitsPerPixel
    
    GetObject hBitmap, LenB(hBmp), hBmp ' We get all the necessary information about the image
    
    If bpp = 0 Then
        bpp = hBmp.bmBitsPixel ' Set the default bits per pixel value for the image
    End If
    
    bInfo.bmiHeader.biHeight = hBmp.bmHeight
    bInfo.bmiHeader.biWidth = hBmp.bmWidth
    bInfo.bmiHeader.biPlanes = hBmp.bmPlanes
    bInfo.bmiHeader.biBitCount = bpp
    bInfo.bmiHeader.biSize = Len(bInfo.bmiHeader)
    
    hdc = GetDC(0) ' We are cheating a little by using the default monitor hDC here
    ret = GetDIBits(hdc, hBitmap, 0, hBmp.bmHeight, ByVal 0&, bInfo, DIB_RGB_COLORS)
    
    If ret Then
        WidthArray = bInfo.bmiHeader.biSizeImage / bInfo.bmiHeader.biHeight
        ReDim bArray((WidthArray * bInfo.bmiHeader.biHeight) - 1)
        
        ret2 = GetDIBits(hdc, hBitmap, 0, hBmp.bmHeight, bArray(0), bInfo, DIB_RGB_COLORS)
        
        If ret2 Then
            Select Case bpp
                Case 1
                    bInfo.bmiHeader.biClrUsed = 2
                    bInfo.bmiHeader.biClrImportant = 2
                    bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
                    nCol = 1
                Case 4
                    bInfo.bmiHeader.biClrUsed = 16
                    bInfo.bmiHeader.biClrImportant = 16
                    bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
                    nCol = 15
                Case 8
                    bInfo.bmiHeader.biClrUsed = 256
                    bInfo.bmiHeader.biClrImportant = 256
                    bInfo.bmiHeader.biCompression = DIB_RGB_COLORS
                    nCol = 255
                Case 16, 24, 32
                    nCol = 0
            End Select
            
            If nCol > 0 Then ' If a palette is needed
                ReDim Palette(nCol)
                
                For i = 0 To nCol
                    Palette(i) = bInfo.bmiColors(i)
                Next
            End If
            
            FileHeader.bfType = &H4D42 ' BM
            FileHeader.bfOffBits = Len(FileHeader) + Len(bInfo.bmiHeader) + IIf(nCol, (nCol + 1) * 4, 0) ' + palette, if needed
            FileHeader.bfSize = Len(FileHeader) + Len(bInfo.bmiHeader) + IIf(nCol, (nCol + 1) * 4, 0) ' + palette, if needed
            FileHeader.bfSize = FileHeader.bfSize + UBound(bArray) + 1
            
            ReDim BmpFileData(FileHeader.bfSize - 1) ' Allocate memory for a BMP file array
            
            ' We collect a BMP file from various structures
            CopyMemory BmpFileData(0), FileHeader.bfType, 2 ' Write FileHeader (stage 1)
            CopyMemory BmpFileData(2), FileHeader.bfSize, Len(FileHeader) - 2 ' Write FileHeader (stage 2)
            CopyMemory BmpFileData(Len(FileHeader)), bInfo.bmiHeader, Len(bInfo.bmiHeader) ' Write BitmapInfoHeader
            If nCol > 0 Then ' If a palette is needed
                CopyMemory BmpFileData(Len(FileHeader) + Len(bInfo.bmiHeader)), Palette(0), (nCol + 1) * 4 ' Write Palette
            End If
            CopyMemory BmpFileData(FileHeader.bfOffBits), bArray(0), UBound(bArray) + 1 ' Write an array of a bitmap
            
            SavePictureAsBitmap = True
        End If
    End If
    
    ReleaseDC 0, hdc
End Function

Новые блоги и статьи Все статьи Все блоги /
Море в объективе kumehtar 06.07.2026 Хотел написать много проникновенных слов, но передумал. Оно само - говорит. Кто слышит тот слышит.	Оказывается, Unreal Engine позволяет качество на порядки выше, чем было в Lineedge Etyuhibosecyu 05.07.2026 Жаль, конечно, что я не узнал об этом, пока Lineedge существовала, а то бы Noname2331 написал, что волки превращаются в пиксельную кашу, а я бы его попросил скачать какую-нибудь бриллиантовую или Pro. . .	Doom для терминала без стрельбы и монстров. 3D Raycasting на ascii. dcc0 05.07.2026 Попросил нейронную сеть deepai. org написать рейкастинг 3D с библиотекой ncurses для Linux. Чтобы можно было ходить на стрелочки. Чтобы стены были отрисованы символами. Справилась. Первый вариант. . .	Установка статуса документа по условию Maks 05.07.2026 Алгоритм из решения ниже реализован на нетиповом документе "НарядПутевка" разработанного в КА2. Задача: в табличной части "Материалы" документа при записи автоматически устанавливать статус. . .
Сезонность и суточность закисления почв anaschu 04.07.2026 200 часов это все равно моловато. Есть ситуации, но нестандартные, когда смена происходит за 5 лет. Но обычно это 50 лет и более. Наверное, закисление почвы происходит сезонно в средней. . .	В чем ценность человеческого опыта в глобальном смысле? kumehtar 03.07.2026 Возможно, ценность человека не в том, что он однажды достигает мудрости, а в том, что он становится носителем карты пути. Он знает не только истину, но и последовательность внутренних изменений,. . .	интеграция AnyLogic с самописным REST API и переход на Odoo anaschu 03.07.2026 Успешная интеграция AnyLogic с самописным REST API и переход на промышленную Odoo WMS Сегодня проделал огромный путь от простой симуляции физических процессов до построения полноценной. . .	Поиск всех путей на ориентированном графе. Linux dcc0 02.07.2026 Переработка старого кода из моей статьи. Через несколько переработок от PHP кода к C89 (надеюсь, 89). Но довольно запутанно получилось. Код для Linux. Но если убрать time и то, что с ним. . .

@HackerVlad Вернулся 1748 / 644 / 45 Регистрация: 10.09.2021 Сообщений: 2,786

	Как сохранить картинку в файл BMP или байтовый массив из Picture1.hdc 21.01.2025, 05:56. Показов 8656. Ответов 82 Метки нет (Все метки) Как сохранить картинку в файл BMP или байтовый массив из Picture1.hdc Может быть уже есть такая удобная функция, которая бы принимала в качестве параметра Picture1.hdc и/или Picture1.Image.handle и сохраняла бы картинку, не в битовую карту, а именно в файл BMP со всеми заголовками BMP. Мне просто интересно, так сказать исходный код для сохранения картинки в BMP. Я сегодня кое что нашёл в Интернете для этих целей, но этого не достаточно. Добавлено через 7 минут Вот тут интересно очень почитать можно: https://moddb.fandom.com/wiki/... nformation Добавлено через 11 минут Вообще я знаю как очень легко сохранить Picture, но мне хотелось бы сохранить не Picture, а то что находится в hdc Именно в файл!!! А не в битовую карту через GetDIBits. 0

@Argus19 1446 / 463 / 78 Регистрация: 24.09.2017 Сообщений: 2,542 Записей в блоге: 24
	23.01.2025, 09:23
	В каком виде изображение хранится в файле ресурсов? 0

@testuser2 1402 / 860 / 93 Регистрация: 08.02.2017 Сообщений: 3,673 Записей в блоге: 2
	23.01.2025, 12:22
	Потом, вот это объявление CopyMemory `Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)` оно как бы каноничное - два аргуента ByRef. Я в основном везде вижу такое объявления, и оно же в Апи-вьювере, и в WinDevLib от fafo. И когда я вижу другое объявление, то это как бы раздражает, я считаю, надо писать как все, не отбиваться от общего стада, т.ск. 0

@HackerVlad Вернулся 1748 / 644 / 45 Регистрация: 10.09.2021 Сообщений: 2,786
	23.01.2025, 12:22 [ТС]
	Считай, что The trick меня обучал программировать здесь вообще... До знакомства с The trick я в API вообще мало что понимал, только готовым кодом пользовался... 0

@HackerVlad Вернулся 1748 / 644 / 45 Регистрация: 10.09.2021 Сообщений: 2,786
	24.01.2025, 17:21 [ТС]
	testuser2, ну что там с тестом? или сегодня опять нет сил? 0

@testuser2 1402 / 860 / 93 Регистрация: 08.02.2017 Сообщений: 3,673 Записей в блоге: 2
	25.01.2025, 04:40
	HackerVlad, точно также у меня, такое же поведение 1

@HackerVlad Вернулся 1748 / 644 / 45 Регистрация: 10.09.2021 Сообщений: 2,786
	25.01.2025, 13:00 [ТС]
	Умники тут меня осуждают вместо того чтобы предоставить свою версию кода. Перепишите. Покажите как лучше. Добавлено через 1 минуту Как хочу так и декларирую. 0

Как сохранить картинку в файл BMP или байтовый массив из Picture1.hdc

Решение