Find Code:
All Words
Any of the Words
Exact Phrase
Home
:
Code
:
Forums
:
Submit
:
Mailing List
:
About
:
Contact
Code
All
VB.NET
ASP.NET
C#
VB Classic
ASP Classic
Snippets
Popular
Resources
Submit Code
Forums
Articles
Tips
Links
Books
Contest
Link to us
This is a Class, called CTgaSave, that takes a pic...
Author:
Bradley Berthold
E-mail:
Click to e-mail author
Website:
http://www.angelfire.com/nt/teklord
Submitted:
10/25/2001
Version:
VB4
Compatibility:
VB4, VB5, VB6
Category:
Graphics
Views:
13912
This is a Class, called CTgaSave, that takes a picture box object and a filename as arguments, and saves out a 24 bit uncompressed TGA image file. Methods: SaveTGA(PictureIn as PictureBox, ByVal Filename as String) Properties: IsError BOOLEAN Tells you if there was an error or not ErrorMessage STRING The error message associated with the error Usage: Dim MyTGA as CTgaSave Set MyTGA = new CTgaSave MyTGA.SaveTGA(Picture1,"c:\windows\desktop\test.tga") if (MyTGA.IsError = False) Then MsgBox("Saved!") Set MyTGA = Nothing IsError is set to false on every call to SaveTGA(), so you can attempt to correct the problem and try saving again normally.
Declarations:
' **************************************** ' CLASS: CTgaSave ' Class Purpose: Takes a Visual Basic Picture box and a filename ' as arguments to the function SaveTGA. Saves the image in the picturebox ' out to a 24 bit RGB color UNCOMPRESSED TGA file. ' **************************************** Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight 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 Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long ' **** These are not needed right now... 'Private Declare Function CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) As Long 'Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, ByVal wUsage As Long, ByVal dwRop As Long) As Long 'Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long 'Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long 'Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long 'Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long 'Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long ' ***** Private Type TGAHEADER ImageIDLength As Byte ColorMapType As Byte ImageTypeCode As Byte colorMapOrigin As Byte colorMapLength As Integer colorMapEntrySize As Integer imageXOrigin As Integer imageYOrigin As Integer imageWidth As Integer imageHeight As Integer bitCount As Byte imageDescriptor As Byte End Type Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte 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 As RGBQUAD End Type Private Type BITMAPFILEHEADER bfType As Integer bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Private Const DIB_RGB_COLORS = 0& Private Const SRCCOPY = &HCC0020 Private Const BI_RGB = 0& Private Const VBM_GETPALETTE = &H101C Private Const GMEM_ZEROINIT = &H40 Private MemDC As Long Private MemBitmap As Long Private OldBitmap As Long Private BMI As BITMAPINFO Private MemHandle As Long Private MemPtr As Long Private junk As Long Private PaletteHandle As Long Private OldPalette As Long Private memsize As Long ' ** These are only needed if you use Windows Global memory 'Private MemCounter As Long 'Private MemValue As Byte 'Private MemOffset As Long ' *** Private BitmapHeader As BITMAPFILEHEADER Private TgaHead As TGAHEADER Private ImageArray() As Byte Private ErrorString As String Public IsError As Boolean
Code:
Private Sub Class_Initialize() IsError = False End Sub Private Sub ErrMsg(ByVal ErrString As String) IsError = True ErrorString = ErrString End Sub Public Sub SaveTGA(PictureIn As PictureBox, ByVal FileName As String) IsError = False On Error GoTo errorhandler ' Check out a few things first.... If (PictureIn.ScaleMode <> 3) Then IsError = True ErrMsg ("Picture Box must be in Pixel scalemode!") Exit Sub End If If (PictureIn.Visible = False) And (PictureIn.AutoRedraw = False) Then IsError = True ErrMsg ("An invisible picture box needs autoredraw turned on!") Exit Sub End If ' Create out Memory Device Context. Compatible with display device. MemDC = CreateCompatibleDC(PictureIn.hdc) If MemDC = 0 Then ErrMsg ("Could not create Memory Device Context") Exit Sub End If ' Create a bitmap comparable with the displayed bitmap MemBitmap = CreateCompatibleBitmap(PictureIn.hdc, PictureIn.ScaleWidth, PictureIn.ScaleHeight) If MemBitmap = 0 Then ErrMsg ("Could not create Memory bitmap") Exit Sub End If ' Select the new bitmap into the DC OldBitmap = SelectObject(MemDC, MemBitmap) ' Bitblt the data we want into our new memory bitmap junk = BitBlt(MemDC, 0, 0, PictureIn.ScaleWidth, PictureIn.ScaleHeight, PictureIn.hdc, 0, 0, SRCCOPY) If junk = 0 Then ErrMsg ("Could Not Blit to memory context") Exit Sub End If 'junk = BitBlt(Picture2.hdc, 0, 0, 100, 100, MemDC, 0, 0, SRCCOPY) 'If junk = 0 Then ShowMsg ("second blit") ' Get the bitmap out of the DC so we can get its data. MemBitmap = SelectObject(MemDC, OldBitmap) ' Set up the Bitmap Info Header to ' request from getGDIBits() BMI.bmiHeader.biSize = Len(BMI.bmiHeader) BMI.bmiHeader.biPlanes = 1 BMI.bmiHeader.biBitCount = 24 BMI.bmiHeader.biHeight = PictureIn.ScaleHeight BMI.bmiHeader.biWidth = PictureIn.ScaleWidth BMI.bmiHeader.biCompression = BI_RGB ' Calculate the memory size (remember to minus 1 afterward!) memsize = ((CLng(PictureIn.ScaleWidth * BMI.bmiHeader.biBitCount + 31) \ 32) * 4 * PictureIn.ScaleHeight) ' Resize our Byte array to store the bitmap data ReDim ImageArray(memsize - 1) ' ****** These functions used Windows Global memory. 'MemHandle = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, (CLng(PictureIn.ScaleWidth * BMI.bmiHeader.biBitCount + 31) \ 32) * 4 * PictureIn.ScaleHeight) 'MemPtr = GlobalLock(MemHandle) 'memsize = GlobalSize(MemHandle) 'junk = GetDIBits(MemDC, MemBitmap, 0, PictureIn.ScaleHeight, ByVal MemPtr, BMI, DIB_RGB_COLORS) ' ******* junk = GetDIBits(MemDC, MemBitmap, 0, PictureIn.ScaleHeight, ImageArray(0), BMI, DIB_RGB_COLORS) If junk = 0 Then ErrMsg ("Get could acquire image data") Exit Sub End If '***** Another Global memory function 'StretchDIBits Picture3.hdc, 0, 0, Picture3.ScaleWidth, Picture3.ScaleHeight, 0, 0, PictureIn.ScaleWidth, PictureIn.ScaleHeight, ByVal MemPtr, BMI, DIB_RGB_COLORS, SRCCOPY '***** 'StretchDIBits Picture3.hdc, 0, 0, Picture3.ScaleWidth, Picture3.ScaleHeight, 0, 0, PictureIn.ScaleWidth, PictureIn.ScaleHeight, ImageArray(0), BMI, DIB_RGB_COLORS, SRCCOPY '*** More global memory requirements. 'CopyMemory ImageArray(0), ByVal MemPtr, memsize ' ***** ' FILL IN THE TGA FILE HEADER... With TgaHead .bitCount = 24 .imageDescriptor = 0 .colorMapEntrySize = 0 .colorMapOrigin = 0 .ImageIDLength = 0 .ColorMapType = 0 .imageHeight = PictureIn.ScaleHeight .imageWidth = PictureIn.ScaleWidth .imageXOrigin = 0 .imageYOrigin = 0 .ImageTypeCode = 2 .colorMapLength = 0 End With If IsError = False Then Open FileName For Binary As #1 ' Write the header, and then the data. ' TGA file format is simple! Put #1, , TgaHead Put #1, , ImageArray Close #1 End If ' *** Last of Global Memory functions. 'GlobalUnlock (MemHandle) 'GlobalFree (MemHandle) ' ***** DeleteDC (MemDC) DeleteObject (MemBitmap) Exit Sub errorhandler: ' set the string, let our parent handle errors. ErrorString = Err.Description IsError = True ' clean up and bomb out of here! If (MemDC <> 0) Then DeleteDC (MemDC) If (MemBitmap <> 0) Then DeleteObject (MemBitmap) End Sub Public Property Get ErrorMessage() As String ErrorMessage = ErrorString End Property Private Sub Class_Terminate() Erase ImageArray End Sub
Home
|
Forums
|
Submit
|
Books
|
Mailing List
|
Advertising
|
About
|
Contact
© 2024 A1VBCode. All rights reserved.
Legal disclaimer & terms of use
Privacy statement