Новичок
Профиль
Группа: Участник
Сообщений: 5
Регистрация: 23.1.2010
Репутация: нет
Всего: нет
|
Программа уже считывает изображение формата *.tga, выводит его в форме, подбрав масштаб. Необходимо, чтобы в форме чуть ниже картинки выводилась палитра - т.е. 255 квадратиков с цветами из картинки. По возможности, сделать вывод картинки не на всю форму, а может в ImageBox или PictureBox. Вот код программы: 1)Главная форма | Код |
'This module contains the interface for displaying Truevision Targa images.
Dim ImageFilePath As String 'The image file or directory containing Truevision Targa image(s).
Dim TGALoader As New TGALoader 'The Truevision Targa image loader.
'This procedure loads and displays the most recently specified/selected image.
Sub DisplayImage()
TGALoader.LoadTGA ImageFilePath
TGALoader.DrawTGA Me
End Sub
'This procedure initializes this program.
Private Sub OpenP_Click()
CommonDialog1.ShowOpen
RequestImagePath
OpenP.Visible = False
End Sub
'This procedure requests an image file or directory and displays the image((s) in the directory.)
Private Sub RequestImagePath()
ImageFilePath = CommonDialog1.FileName
DisplayImage
End Sub
|
а вот подключаемый модуль: TGALoader | Код |
'This module contains the functions for loading and displaying True Vision Targa (.TGA) images.
Option Explicit
'This structure contains the bitmap information header.
Private Type BITMAPINFOHEADER
biSize As Long 'Contains the size of the information header.
biWidth As Long 'Contains the width of the bitmap in pixels.
biHeight As Long 'Contains the height of the bitmap in pixels.
biPlanes As Integer 'Contains the number of bit planes for the target device.
biBitCount As Integer 'Contains the number bits of per pixel.
biCompression As Long 'Specifies whether the bitmap is compressed.
biSizeImage As Long 'Contains the size of the bitmap in bytes.
biXPelsPerMeter As Long 'Contains the number of horizontal pixels per meter to be used for the bitmap by the target device.
biYPelsPerMeter As Long 'Contains the number of vertical pixels per meter to be used for the bitmap by the target device.
biClrUsed As Long 'Contains the number of colors in the bitmap's palette.
biClrImportant As Long 'Contains the number of colors required to display the bitmap.
End Type
'The Microsoft Windows API constants.
Private Const BI_RGB As Long = &H0
Private Const CBM_INIT As Long = &H4
Private Const DIB_RGB_COLORS As Long = &H0
Private Const SRCCOPY As Long = &HCC0020
'The Microsoft Windows API functions used.
Private Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CreateCompatibleDC Lib "Gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBitmap Lib "Gdi32.dll" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As BITMAPINFOHEADER, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBitmap_8 Lib "Gdi32.dll" Alias "CreateDIBitmap" (ByVal hdc As Long, lpInfoHeader As BITMAPINFOHEADER, ByVal dwUsage As Long, lpInitBits As Any, lpInitInfo As Bitmap8Bit, ByVal wUsage As Long) As Long
Private Declare Function DeleteDC Lib "Gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "Gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function SelectObject Lib "Gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "Gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal BitmapWidth As Long, ByVal BitmapHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'This structure contains the TGA image header.
Private Type TGAHeader
InformationBlockSize As Byte 'The length of the image information block.
ColorType As Byte 'DAC table or BGR format.
ImageType As Byte 'The image type.
Origin As Integer 'The first entry in the DAC table.
ColorCount As Integer 'The number of colors in the DAC table.
EntryBits As Byte 'The number of bits per color in the DAC table.
LowerLeftCornerX As Integer 'The x coordinate of the lower left corner.
LowerLeftCornerY As Integer 'The y coordinate of the lower left corner.
ImageWidth As Integer 'The image width.
ImageHeight As Integer 'The image height.
BitsPerPixel As Byte 'The number of bits per pixel.
Descriptor As Byte 'The image descriptor.
End Type
'This structure contains the red, green and blue color structure.
Private Type RGBColor
Blue As Byte
Green As Byte
Red As Byte
End Type
'This structure contains the red, green, blue and reserved color structure.
Private Type RGBRColor
Blue As Byte
Green As Byte
Red As Byte
Reserved As Byte
End Type
'This structure contains the information header and pallete for 8 bit bitmaps.
Private Type Bitmap8Bit
bmiHeader As BITMAPINFOHEADER
bmiColors(255) As RGBRColor
End Type
'The TGA image type constants.
Private Const TGAColorMap As Byte = 1 'Uncompressed color-mapped image.
Private Const TGARGB As Byte = 2 'Uncompressed RGB image.
Private Const TGAMonochrome As Byte = 3 'Uncompressed black and white image.
Private Const TGARLEColorMap As Byte = 9 'Runlength encoded color-mapped image.
Private Const TGARLERGB As Byte = 10 'Runlength encoded RGB image.
Private Bitmap8Bit As Bitmap8Bit 'Contains information about 8 bit bitmaps.
Private BitmapHandle As Long 'Contains the handle to the bitmap data.
Private BitmapHeader As BITMAPINFOHEADER 'Contains the bitmap information header.
Private BitmapHeight As Long 'Contains the height of the current image in pixels.
Private BitmapWidth As Long 'Contains the width of the current image in pixels.
Private Orientation As Integer 'Indicates whether the bitmap is rightside up.
Private ResizeCanvasV As Boolean 'Specifies whether the size of the canvas is adjusted to fit the current TGA image.
Private ScaleModeV As Integer 'Specifies which unit of measurement is used.
Private TGAHeader As TGAHeader 'Contains the header of the current TGA image.
'This procedure initializes the TGA image loader.
Private Sub Class_Initialize()
ResizeCanvasV = True
End Sub
'This procedure creates a bitmap from the pixel data.
Private Sub Create16BitBitmap(BitmapData() As Byte, BitmapWidth As Long, BitmapHeight As Long, Orientation As Integer)
Dim BitmapDC As Long
With BitmapHeader
.biSize = Len(BitmapHeader)
.biWidth = BitmapWidth
.biHeight = IIf(Orientation = 0, BitmapHeight, -BitmapHeight)
.biPlanes = 1
.biBitCount = 16
.biCompression = BI_RGB
.biSizeImage = 0
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
BitmapDC = GetDC(0)
BitmapHandle = CreateDIBitmap(BitmapDC, BitmapHeader, CBM_INIT, BitmapData(0), BitmapHeader, DIB_RGB_COLORS)
DeleteDC BitmapDC
End Sub
'This procedure creates a bitmap from the pixel data.
Private Sub Create24BitBitmap(BitmapData() As Byte, BitmapWidth As Long, BitmapHeight As Long, Orientation As Integer)
Dim BitmapDC As Long
With BitmapHeader
.biSize = Len(BitmapHeader)
.biWidth = BitmapWidth
.biHeight = IIf(Orientation = 0, BitmapHeight, -BitmapHeight)
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
.biSizeImage = 0
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
BitmapDC = GetDC(0)
BitmapHandle = CreateDIBitmap(BitmapDC, BitmapHeader, CBM_INIT, BitmapData(0), BitmapHeader, DIB_RGB_COLORS)
DeleteDC BitmapDC
End Sub
'This procedure creates a bitmap from the pixel data.
Private Sub Create8BitBitmap(BitmapData() As Byte, BitmapWidth As Long, BitmapHeight As Long, Orientation As Integer)
Dim BitmapDC As Long
With Bitmap8Bit.bmiHeader
.biSize = Len(Bitmap8Bit.bmiHeader)
.biWidth = BitmapWidth
.biHeight = IIf(Orientation = 0, BitmapHeight, -BitmapHeight)
.biPlanes = 1
.biBitCount = 8
.biCompression = BI_RGB
.biSizeImage = 0
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0
.biClrImportant = 0
End With
BitmapDC = GetDC(0)
BitmapHandle = CreateDIBitmap_8(BitmapDC, Bitmap8Bit.bmiHeader, CBM_INIT, BitmapData(0), Bitmap8Bit, DIB_RGB_COLORS)
DeleteDC BitmapDC
End Sub
'This procedure draws the bitmap created from the current TGA image on the specified canvas.
Public Sub DrawTGA(Canvas As Object)
Dim CanvasDC As Long, CanvasHeight As Long, CanvasWidth As Long, PreviousScaleMode As Long, PreviousParentScaleMode As Long
Canvas.Cls
Canvas.ScaleMode = vbTwips
Canvas.Width = PixelsToTwipsX(BitmapWidth)
Canvas.Height = PixelsToTwipsY(BitmapHeight)
CanvasWidth = TwipsToPixelsX(Canvas.Width)
CanvasHeight = TwipsToPixelsY(Canvas.Height)
CanvasDC = CreateCompatibleDC(Canvas.hdc)
SelectObject CanvasDC, BitmapHandle
StretchBlt Canvas.hdc, 0, 0, CanvasWidth, CanvasHeight, CanvasDC, 0, 0, BitmapWidth, BitmapHeight, SRCCOPY
Canvas.Picture = Canvas.Image
End Sub
'This procedure extracts and returns the specified bit from the specified byte.
Private Function GetBit(Bits As Byte, BitIndex As Long) As Integer
Dim BitMask As Byte
BitMask = 2 ^ (8 - BitIndex)
GetBit = (GetBit And BitMask) / BitMask
End Function
'This procedure loads the specified 16 bit color TGA image and creates a bitmap from it.
Private Sub Load16BitTGA(FileName As String)
Dim BitmapData() As Byte, FileHandle As Integer, TGAImageData() As Byte
FileHandle = FreeFile
Open FileName For Binary Lock Write As FileHandle
Seek FileHandle, 1
Get FileHandle, , TGAHeader
With TGAHeader
BitmapWidth = .ImageWidth - .LowerLeftCornerX
BitmapHeight = .ImageHeight - .LowerLeftCornerY
Orientation = GetBit(.Descriptor, 3)
End With
ReDim TGAImageData(LOF(FileHandle) - Len(TGAHeader)) As Byte
Get FileHandle, , TGAImageData()
Close FileHandle
BitmapData() = TGAImageData()
End If
Create16BitBitmap BitmapData(), BitmapWidth, BitmapHeight, Orientation
End Sub
'This procedure loads the specified 24 bit color TGA image and creates a bitmap from it.
Private Sub Load24BitTGA(FileName As String)
Dim BitmapData() As Byte, FileHandle As Integer, Pixel As Long, RGBRImageData() As RGBRColor, TGAImageData() As Byte
FileHandle = FreeFile
Open FileName For Binary Lock Write As FileHandle
Seek FileHandle, 1
Get FileHandle, , TGAHeader
With TGAHeader
BitmapWidth = .ImageWidth - .LowerLeftCornerX
BitmapHeight = .ImageHeight - .LowerLeftCornerY
Orientation = GetBit(.Descriptor, 3)
End With
ReDim TGAImageData(LOF(FileHandle) - Len(TGAHeader)) As Byte
Get FileHandle, , TGAImageData()
Close FileHandle
ReDim RGBRImageData(UBound(TGAImageData) / 3) As RGBRColor
For Pixel = 0 To (UBound(TGAImageData) / 3) - 1
With RGBRImageData(Pixel)
.Blue = TGAImageData(Pixel * 3)
.Green = TGAImageData((Pixel * 3) + 1)
.Red = TGAImageData((Pixel * 3) + 2)
End With
Next Pixel
ReDim BitmapData((UBound(RGBRImageData) * 4) + 4) As Byte
CopyMemory BitmapData(0), RGBRImageData(0), UBound(BitmapData)
Create24BitBitmap BitmapData(), BitmapWidth, BitmapHeight, Orientation
End Sub
'This procedure loads the specified 256 color TGA image.
Private Sub Load8BitTGA(FileName As String)
Dim BitmapData() As Byte, BytesPerRow As Long, FileHandle As Integer, Index As Long, RGBPalette() As RGBColor
FileHandle = FreeFile
Open FileName For Binary Lock Write As FileHandle
Seek FileHandle, 1
Get FileHandle, , TGAHeader
With TGAHeader
BitmapWidth = .ImageWidth - .LowerLeftCornerX
BitmapHeight = .ImageHeight - .LowerLeftCornerY
BytesPerRow = .ImageWidth
End With
If TGAHeader.EntryBits = 24 Then
ReDim RGBPalette(TGAHeader.ColorCount - 1) As RGBColor
Get FileHandle, , RGBPalette()
For Index = 0 To 255
Bitmap8Bit.bmiColors(Index).Blue = RGBPalette(Index).Blue
Bitmap8Bit.bmiColors(Index).Green = RGBPalette(Index).Green
Bitmap8Bit.bmiColors(Index).Red = RGBPalette(Index).Red
Bitmap8Bit.bmiColors(Index).Reserved = 0
Next Index
End If
ReDim BitmapData(LOF(FileHandle) - Len(TGAHeader) - (UBound(RGBPalette) * 3)) As Byte
Get FileHandle, , BitmapData()
Orientation = GetBit(TGAHeader.Descriptor, 3)
Close FileHandle
Create8BitBitmap BitmapData(), BitmapWidth, BitmapHeight, Orientation
End Sub
'This procedure loads the specified TGA image's header.
Public Function LoadTGA(FileName As String) As StdPicture
Dim FileHandle As Integer
FileHandle = FreeFile
Open FileName For Input As FileHandle: Close FileHandle
Open FileName For Binary Lock Write As FileHandle
Seek FileHandle, 1
Get FileHandle, , TGAHeader
Close FileHandle
If TGAHeader.BitsPerPixel = 8 Then Load8BitTGA FileName
If TGAHeader.BitsPerPixel = 16 Then Load16BitTGA FileName
If TGAHeader.BitsPerPixel = 24 Then Load24BitTGA FileName
End Function
'This procedure converts the specified length of a horizontal row of pixels to twips.
Private Function PixelsToTwipsX(Pixels As Long) As Long
PixelsToTwipsX = Pixels * Screen.TwipsPerPixelX
End Function
'This procedure converts the specified length of a vertical row of pixels to twips.
Private Function PixelsToTwipsY(Pixels As Long) As Long
PixelsToTwipsY = Pixels * Screen.TwipsPerPixelY
End Function
'This procedure converts the specified length of a horizontal row of twips to pixels.
Private Function TwipsToPixelsX(Twips As Long) As Long
TwipsToPixelsX = Twips / Screen.TwipsPerPixelX
End Function
'This procedure converts the specified length of a vertical column of twips to pixels.
Private Function TwipsToPixelsY(Twips As Long) As Long
TwipsToPixelsY = Twips / Screen.TwipsPerPixelY
End Function
'This procedure returs the height and width of the current TGA image in either twips or pixels.
Public Property Get TGAHeight() As Long
If ScaleModeV = vbUser Then
TGAHeight = BitmapHeight
TGAWidth = BitmapWidth
End If
If ScaleModeV = vbTwips Then
TGAHeight = PixelsToTwipsY(BitmapHeight)
TGAWidth = PixelsToTwipsX(BitmapWidth)
End If
End Property
|
|
[visual basic 6.0] Работа с форматом *.tga, Добавление палитры на форму из файла 
Загрузка ...
