- Код: Выделить всё
'Header for blizzards .blp(1) files (this code is anti jpeg, for now)
Private Type BLP1_HEADER
bBLPid As Long
bIsPal As Long
bMipMaps As Long
bWidth As Long
bHeight As Long
bUnknown1 As Long
bUnknown2 As Long
bPicPtr(15) As Long
bPicLen(15) As Long
End Type
'for the pallet
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
'Bit Map
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
Public Type BITMAPSTRUT
Width As Long
Height As Long
handle As Long
End Type
'for the API containing both pallet and bitmap header
Private Type BITMAPINFO_8
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBQUAD
End Type
Public W3IconTest() As BITMAPSTRUT
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)
Private Declare Function CreateDIBitmap_8 Lib "gdi32" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFO_8, ByVal wUsage As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public 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
Public Function LoadBLP(ByVal FilePath As String, ByRef BMPArray() As BITMAPSTRUT) As Boolean
Dim FF As Integer: FF = FreeFile
Dim FileData() As Byte
Dim tmpBMP() As Byte
Dim blpHeader As BLP1_HEADER
Dim BMP8 As BITMAPINFO_8
Dim i As Integer
Dim hdc As Long
LoadBLP = False
'open file and extract data
Open FilePath For Binary As #FF
ReDim FileData(LOF(FF) - 1)
Get FF, , FileData
Close #FF
'copy header data into header type
Call CopyMemory(blpHeader, FileData(0), 156)
'Check its a blp file
If Not blpHeader.bBLPid = &H31504C42 Then Exit Function 'BLP1
'Check its a raw blp format (not jpeg)
If Not blpHeader.bIsPal = 1 Then Exit Function 'its jpeg
'copy the pallet into are bitmap RGBQUAD
Call CopyMemory(BMP8.bmiColors(0), FileData(156), 1024)
'add needed info to the bitmap header for when the API creates it
With BMP8.bmiHeader
.biSize = Len(BMP8.bmiHeader)
.biWidth = blpHeader.bWidth
.biHeight = blpHeader.bHeight
.biPlanes = 1
.biBitCount = 8
End With
'Create a bitmap in memory from the set data, and get the handle to it
For i = 0 To 15
'Check theres a pointer to the picture data, other wise last image was loaded last for
If blpHeader.bPicPtr(i) = 0 And i > 0 Then Exit For
'Copy the first bitmap into tmpBMP()
ReDim tmpBMP(blpHeader.bPicLen(i) - 1)
Call CopyMemory(tmpBMP(0), FileData(blpHeader.bPicPtr(i)), blpHeader.bPicLen(i))
'flip/mirror/lower bits of the bitmap data
Call MakeBitmap_8(tmpBMP(), BMP8.bmiHeader.biWidth, BMP8.bmiHeader.biHeight)
'Create a bitmap and put it into the correct index of BMPArray
hdc = GetDC(0)
ReDim Preserve BMPArray(i)
BMPArray(i).Width = BMP8.bmiHeader.biWidth
BMPArray(i).Height = BMP8.bmiHeader.biHeight
BMPArray(i).handle = CreateDIBitmap_8(hdc, BMP8.bmiHeader, &H4, tmpBMP(0), BMP8, &H0)
'BitBlt Form1.Picture1.hdc, 0, 0, BMPArray(0).Width, BMPArray(0).Height, hdc, 0, 0, vbSrcCopy
Call DeleteDC(hdc)
'lower image size to the next image block's size
BMP8.bmiHeader.biWidth = BMP8.bmiHeader.biWidth / 2
BMP8.bmiHeader.biHeight = BMP8.bmiHeader.biHeight / 2
'Alwas return true if a bitmap was created
LoadBLP = True
Next i
'erase the file/bitmap datas
Erase FileData()
Erase tmpBMP()
End Function
Private Sub MakeBitmap_8(imgArray() As Byte, Lines As Long, BytesLine As Long)
Dim tmpBM() As Byte, G As Long, GBMP As Long, i As Long, i2 As Long, tmpBMX As Long
If (BytesLine Mod 4) = 0 Then
tmpBMX = BytesLine - 1
Else
tmpBMX = (BytesLine \ 4) * 4 + 3
End If
G = Lines * BytesLine
GBMP = Lines * (tmpBMX + 1) - 1
ReDim tmpBM(UBound(imgArray))
CopyMemory tmpBM(0), imgArray(0), UBound(imgArray) + 1
ReDim imgArray(GBMP)
For i = 0 To BytesLine * Lines - BytesLine Step BytesLine
CopyMemory imgArray(i2), tmpBM(G - i - BytesLine), BytesLine
i2 = i2 + tmpBMX + 1
Next i
Erase tmpBM()
End Sub
Я пытался сделать так:
- Код: Выделить всё
Dim hRet As Long
LoadBLP "C:\234.blp", W3IconTest
hRet = GetDC(W3IconTest(0).handle)
BitBlt Picture1.hdc, 0, 0, W3IconTest(0).Width, W3IconTest(0).Height, hRet, 0, 0, vbSrcCopy
Для примера я приаттачил картинку в этом формате (http://forum.valhallalegends.com/index. ... ic=14286.0 ссылка на топик, откуда я взял эти функции). Ещё 1 знакомый сделал библиотеку по открытию, но описание функций открытия на делфи, а как использовать её в VB я понятия не имею, а вообще вот описание и сама библиотека http://xgm.ru/forum/showpost.php?p=526887&postcount=9
