VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "clsOffScreenDC" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False ' +————————————————————————————————————————————————+ ' ‡ - Name: Paul Birtle ‡ ' ‡ - Email: Owner@Electroman.co.uk ‡ ' ‡ - Web: http;//www.Electroman.co.uk/ ‡ ' ‡ - Company: Electroman Programming ‡ ' ‡ - Date/Time: 12/1/03 20:05:11 ‡ ' ‡ ‡ ' +————————————————————————————————————————————————+ ' ‡ - NOTES: Please leave this box in place ‡ ' ‡ because this has taken a lot of my time ‡ ' ‡ to create. You are free to use this ‡ ' ‡ class in your projects and end programs. ‡ ' ‡ All I ask is that you agknowledge me in ‡ ' ‡ your program/code, AboutBox or something. ‡ ' ‡ Hope this class is of use to you. ‡ ' ‡ ‡ ' +————————————————————————————————————————————————+ '------------- API Declarations-------------------------------------------------------- Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long Private Declare Function VarPtr Lib "msvbvm50.dll" (Ptr As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) 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 '-------------------------------------------------------------------------------------- '------A few types that will be needed------------------------------------------------- Private Type SAFEARRAYBOUND cElements As Long lLbound As Long End Type Private Type SAFEARRAY2D cDims As Integer fFeatures As Integer cbElements As Long cLocks As Long pvData As Long Bounds(0 To 1) As SAFEARRAYBOUND End Type Private Type Bitmap bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type '-------------------------------------------------------------------------------------- Public DC As Long Private hBitmap As Long Private dPicture As StdPicture 'Or "As IPictureDisp" ,doesn't make a differance Private Height As Long 'because there the same. Private Width As Long 'Max size of the upper bound of an array is 2,147,483,647 'That means max pixels is 715,827,882 'Note: 26754 x 26754 = 715,776,516 pixels '-----Retrieving Procedures------------------------------------------------------------ Public Function GetHeight() As Long If DC = 0 Then Exit Function 'Doesn't exist yet GetHeight = Height End Function Public Function GetWidth() As Long If DC = 0 Then Exit Function 'Doesn't exist yet GetWidth = Width End Function Public Sub GetSize(ByRef rHeight As Long, ByRef rWidth As Long) If DC = 0 Then Exit Sub 'Doesn't exist yet rHeight = Height rWidth = Width End Sub Public Function GetPictureObject() As StdPicture If DC = 0 Then Exit Function 'Doesn't exist yet Set GetPictureObject = dPicture End Function Public Sub GetByteArray(ByRef rPic() As Byte) Dim i As Long 'Current Pixels Xpos, Note: 0 is Left Dim j As Long 'Current Pixels YPos, Note: 0 is Bottom Dim Pic() As Byte 'Will be used to edit the pixels Dim sa As SAFEARRAY2D 'Structure of the 2D array Dim bmp As Bitmap 'Details of the picture Dim r As Long, g As Long, b As Long 'Red, green + blue values Dim sR As Integer, sG As Integer, sB As Integer If DC = 0 Then Exit Sub 'Doesn't exist yet 'Pass the IPictureDisp object to get its details... GetObjectAPI dPicture, Len(bmp), bmp 'This will allow us to create a 2D array as the 'SAFEARRAY2D type is how VB manages 2D arrays... With sa .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = bmp.bmHeight ' .Bounds(1).lLbound = 0 .Bounds(1).cElements = bmp.bmWidthBytes ' .pvData = bmp.bmBits End With 'Links Pic() to the picture in the DC, any changes 'made to Pic() are seen in the picture in the DC... CopyMemory ByVal VarPtrArray(Pic), VarPtr(sa), 4 ReDim rPic(0 To UBound(Pic, 1), 0 To UBound(Pic, 2)) 'Copy data straight over... rPic() = Pic() CopyMemory ByVal VarPtrArray(Pic), 0&, 4 End Sub Public Sub Get1DByteArray(ByRef BArray() As Byte) Dim Pic() As Byte Dim i As Long Dim j As Long Dim a As Long Dim ByteCount As Long If DC = 0 Then Exit Sub 'Doesn't exist yet ByteCount = (Height * Width * 3) ReDim BArray(0 To ByteCount - 1) 'GetByteArray is a fast procedure so I will just use it 'instead of writing a changed version f its code here 'the only change would be replacing "rPic() = Pic()" with 'the nested For loops below... GetByteArray Pic() For i = 0 To (Width * 3) - 1 For j = 0 To Height - 1 BArray(a) = Pic(i, j) a = a + 1 Next Next End Sub '-------------------------------------------------------------------------------------- '-----Handleing\Editing Procedures----------------------------------------------------- Public Sub SetByteArray(ByRef sPic() As Byte) Dim i As Long 'Current Pixels Xpos, Note: 0 is Left Dim j As Long 'Current Pixels YPos, Note: 0 is Bottom Dim Pic() As Byte 'Will be used to edit the pixels Dim sa As SAFEARRAY2D 'Structure of the 2D array Dim bmp As Bitmap 'Details of the picture If DC = 0 Then Exit Sub 'Doesn't exist yet 'Pass the IPictureDisp object to get its details... GetObjectAPI dPicture, Len(bmp), bmp 'This will allow us to create a 2D array as the 'SAFEARRAY2D type is how VB manages 2D arrays... With sa .cbElements = 1 .cDims = 2 .Bounds(0).lLbound = 0 .Bounds(0).cElements = bmp.bmHeight ' .Bounds(1).lLbound = 0 .Bounds(1).cElements = bmp.bmWidthBytes ' .pvData = bmp.bmBits End With 'Links Pic() to the picture in the DC, any changes 'made to Pic() are seen in the picture in the DC... CopyMemory ByVal VarPtrArray(Pic), VarPtr(sa), 4 'Must change each value when seting pic array... For i = 0 To UBound(Pic, 1) - 2 Step 3 For j = 0 To UBound(Pic, 2) If UBound(sPic, 1) <= i - 1 Then 'Ran out of data Pic(i + 2, j) = 0 Pic(i + 1, j) = 0 Pic(i, j) = 0 Else Pic(i + 2, j) = sPic(i + 2, j) 'Red value for this pixel Pic(i + 1, j) = sPic(i + 1, j) 'Green value for this pixel Pic(i, j) = sPic(i, j) 'Blue value for this pixel End If Next Next LeaveLoop: ' 'This is another way but it does byte by byte ' 'Note: Each byte is a color channel not a pixel, ' 'Each pixel has 3 color channels RED, GREEN + BLUE ' For i = 0 To UBound(pic, 1) ' For j = 0 To UBound(pic, 2) ' pic(i, j) = 255 - pic(i, j) ' Next ' Next CopyMemory ByVal VarPtrArray(Pic), 0&, 4 End Sub Public Sub Set1DByteArray(ByRef BArray() As Byte, ByVal tHeight As Long, ByVal tWidth As Long) Dim Pic() As Byte Dim i As Long Dim j As Long Dim a As Long 'This procedure turns a 1 Dimensional Byte array into a 2 Dimensional 'byte array given the Height and Width to be put in the picture. If DC = 0 Then Exit Sub 'Doesn't exist yet ReDim Pic(0 To (tWidth * 3 - 1), 0 To tHeight) For i = 0 To (tWidth * 3) - 1 For j = 0 To tHeight - 1 If a = UBound(BArray) + 1 Then 'Ran out of data Pic(i, j) = 0 Else Pic(i, j) = BArray(a) a = a + 1 End If Next Next SetByteArray Pic End Sub Public Sub SaveFile(ByVal iFilename As String) If DC = 0 Then Exit Sub 'Doesn't exist yet SavePicture dPicture, iFilename End Sub Public Sub CreateImage(ByVal sHeight As Long, ByVal sWidth As Long) If sHeight <= 0 Or sWidth <= 0 Then Exit Sub If Not DC = 0 Then DeleteDC DC 'Just incase it is already active DC = CreateCompatibleDC(0) hBitmap = CreateCompatibleBitmap(frmMain.hdc, sWidth, sHeight) 'Throw bitmap into DC... SelectObject DC, hBitmap Width = sWidth Height = sHeight GetDCsObject 'This sub just gets rid of the hBitmap and retrieves the dPicture End Sub Public Sub LoadFile(ByVal iFilename As String) On Error GoTo 1 Dim bmp As Bitmap If Not DC = 0 Then DeleteDC DC 'Just incase it is already active DC = CreateCompatibleDC(0) Set dPicture = LoadPicture(iFilename) SelectObject DC, dPicture 'Find out the Width and Height... GetObjectAPI dPicture, Len(bmp), bmp Height = bmp.bmHeight Width = bmp.bmWidth 'This is just in case, we wouldn't want to lose memory now would we... If Not hBitmap = 0 Then DeleteObject hBitmap hBitmap = 0 Exit Sub 1 MsgBox "Error - " & Err.Description, vbCritical, "Error!" End Sub Public Function ResizeDC(ByVal newHeight As Long, ByVal newWidth As Long) Dim NewDC As Long If DC = 0 Then Exit Function 'Doesn't exist yet If newWidth <= 0 Then newWidth = Width 'If invalid width given ignor its change If newHeight <= 0 Then newHeight = Height 'If invalid height given ignor its change NewDC = CreateCompatibleDC(DC) hBitmap = CreateCompatibleBitmap(frmMain.hdc, newWidth, newHeight) 'Throw bitmap into NewDC... SelectObject NewDC, hBitmap 'Copy old data over... BitBlt NewDC, 0, 0, newWidth, newHeight, DC, 0, 0, vbSrcCopy 'Delete old one... DeleteDC DC 'Update data... Width = newWidth Height = newHeight DC = NewDC GetDCsObject 'This sub just gets rid of the hBitmap and retrieves the dPicture End Function Public Sub RemoveDC() DeleteDC DC If Not hBitmap = 0 Then DeleteObject hBitmap 'Only need to remove it if it exists Set dPicture = Nothing End Sub '-------------------------------------------------------------------------------------- '-----Internal Procedures-------------------------------------------------------------- Private Sub GetDCsObject() 'Gets rid of the hBitmap and retrieves the dPicture... 'Get the IPictureDisp object... Set dPicture = CreatePicture(hBitmap, vbPicTypeBitmap) 'The IPictureDisp object we got is good enough for saving but isn't 'good enough for what we need it for so we will save the picture 'using it then reload it and the new one will be suitable for our 'needes. However we will need to link it up to the DC again but 'won't be able to get the hBitmap this way so we get rid of it. SavePicture dPicture, "C:\Windows\Temp\DCReload.bmp" Set dPicture = LoadPicture("C:\Windows\Temp\DCReload.bmp") 'Link the DC to the new Object... SelectObject DC, dPicture 'Delete the hBitmap... DeleteObject hBitmap hBitmap = 0 'This is so in the Remove Sub we can tell its already been done. End Sub 'I didn't write this function myself but i'm sorry to say I can't remember who I got it 'off so i can't give them credit. Private Function CreatePicture(ByVal hImage As Long, ByVal ltype As Long) As IPictureDisp 'This function creates a picture object from a handle to a bitmap or a icon 'hImage is the handle to the bitmap or icon 'Type is the type of the image (can be either vbPicTypeBitmap or vbPicTypeIcon) Dim PicInfo As PicBmp Dim TmpPic As IPictureDisp Dim IID_IDispatch As GUID 'Setup the Guid for the function With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With 'Setup the pic structure With PicInfo .Size = Len(PicInfo) .Type = ltype .hBmp = hImage End With 'create the picture OleCreatePictureIndirect PicInfo, IID_IDispatch, 1, TmpPic Set CreatePicture = TmpPic End Function '--------------------------------------------------------------------------------------