新聞財經娛樂♬資訊 News Economy

I've just done capture a window image and save it to a file like jpeg or gif or bmp format.
Acutally I would like to do image recongizing as text  work so now I think I need to save the image
as small size as possible, how could I save the image file to white and black or monochrome
format in VBA ? I try to change hdc = GetDC(DeskHwnd) to
hdc = GetDC(0)  in sub of SaveSelectionAsBMP() but that  doesn't work. So any suggestion
The second question,  since my image is just 4k byte (if in monchrome format), so I would like
to know how I know the file is compressed or not during file saving with the mono color bmp format.
ANy good website for bmp format study ? So that I can use hex editor to study the file

Please advise

Duncan

Complete capture window image and save a file================================================Function ScreenToClipBoard2()Dim ActiveHwnd As LongDim DeskHwnd As LongDim ForegroundHwnd As LongDim hdc As LongDim hdcMem As LongDim rect As rectDim junk As LongDim fwidth As Long, fheight As LongDim hBitmap As Long    '---------------------------------------------------    ' Get window handle to Windows and Microsoft Access    '---------------------------------------------------    DeskHwnd = GetDesktopWindow()    ActiveHwnd = GetActiveWindow()   ' ActiveHwnd = &H1D065C  ActiveHwnd = &H1208E4    ForegroundHwnd = GetForegroundWindow()    '---------------------------------------------------    ' Get screen coordinates of Active Window    '---------------------------------------------------    Call GetWindowRect(ActiveHwnd, rect)    ' or    ' Call GetWindowRect(ForegroundHwnd, rect)    fwidth = rect.Right - rect.Left    fheight = rect.Bottom - rect.Top    '---------------------------------------------------    ' Get the device context of Desktop and allocate memory    '---------------------------------------------------    hdc = GetDC(DeskHwnd)    hdcMem = CreateCompatibleDC(hdc)    hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)    If hBitmap <> 0 Then       junk = SelectObject(hdcMem, hBitmap)       '---------------------------------------------       ' Copy the Desktop bitmap to memory location       ' based on Microsoft Access coordinates.       '---------------------------------------------       junk = BitBlt(hdcMem, 0, 0, fwidth, fheight, hdc, rect.Left, _                     rect.Top, SRCCOPY)       '---------------------------------------------       ' Set up the Clipboard and copy bitmap       '---------------------------------------------       junk = OpenClipboard(DeskHwnd)       junk = EmptyClipboard()       junk = SetClipboardData(CF_BITMAP, hBitmap)      ' Range("A1").Select       'ActiveSheet.Paste       SaveSelectionAsBMP       junk = CloseClipboard()    End If    '---------------------------------------------    ' Clean up handles    '---------------------------------------------    junk = DeleteDC(hdcMem)    junk = ReleaseDC(DeskHwnd, hdc)End Function Sub SaveSelectionAsBMP()        Dim oImageIcon As CommandBarControl        Dim intFaceId As Integer        Dim IID_IDispatch As GUID        Dim uPicinfo As uPicDesc        Dim IPic As IPicture        Dim hPtr As Long        Dim FilePathName As Variant       ' Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap        strPictureFile = Application.GetSaveAsFilename("", "JPEG Files (*.jpeg), *.jpeg", , "Save as JPEG")        If strPictureFile = "False" Then Exit Sub        OpenClipboard 0        hPtr = GetClipboardData(CF_BITMAP)        CloseClipboard         'Create the interface GUID for the picture        With IID_IDispatch            .Data1 = &H7BF80980            .Data2 = &HBF32            .Data3 = &H101A            .Data4(0) = &H8B            .Data4(1) = &HBB            .Data4(2) = &H0            .Data4(3) = &HAA            .Data4(4) = &H0            .Data4(5) = &H30            .Data4(6) = &HC            .Data4(7) = &HAB        End With         ' Fill uPicInfo with necessary parts.        With uPicinfo            .Size = Len(uPicinfo) ' Length of structure.            .Type = PICTYPE_BITMAP ' Type of Picture            .hPic = hPtr ' Handle to image.            .hPal = 0 ' Handle to palette (if bitmap).        End With         'Create the Picture Object        OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic         'Save Picture        stdole.SavePicture IPic, strPictureFile         'fix the clipboard (it seems to go messed up)        Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap    End Sub                                  

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:

to convert it into mono from improving my code above,

nOT MUCH POINT IF YOU CAN DO BETTER with mWSnap. colour alway helps

Use: mW Snap from:

http://mwsnap.en.softonic.com/ it's free & v good - fast & small files

Hi,

I found this for you , i hope it's useful :) cheers , Wellous

Here's a procedure for saving a picturebox's image as a black & white bmp file. I finally got back to that old project and figured it out. GetDIBits did the trick.
All white pixels are saved as white. Anything other than white is saved as black. It doesn't do greyscale or dithering, so photos will come out pretty much all black.  This procedure creates a file about 24 times smaller than the SavePicture statement.


Private Sub SavePictureBW(ByVal ctrl As PictureBox, ByVal destfile As String)
Dim hdcMono As Long, hbmpMono As Long, hbmpOld As Long, dxBlt As Long, dyBlt As Long, success As Long
Dim numscans As Long, byteswide As Long, totalbytes As Long, lfilesize As Long
Dim bmpsrc As BITMAP, bmpdst As BITMAP
Dim bInfo As BITMAPINFO
Dim bitmaparray() As Byte, fileheader() As Byte
Dim ff As Integer

'Object's scalemode must be Pixel.
dxBlt = ctrl.ScaleWidth
dyBlt = ctrl.ScaleHeight

'Create monochrome bitmap from control.
hdcMono = CreateCompatibleDC(0)
hbmpMono = CreateCompatibleBitmap(hdcMono, dxBlt, dyBlt)
success = GetBitmapObject(hbmpMono, Len(bmpsrc), bmpsrc)
hbmpOld = SelectObject(hdcMono, hbmpMono)
success = BitBlt(hdcMono, 0, 0, dxBlt, dyBlt, ctrl.hdc, 0, 0, SRCCOPY)

'Calculate array size needed for bitmap bits (dword aligned)
numscans = dyBlt
by8 = dxBlt / 8
If (dxBlt Mod 8) = 0 And (by8 Mod 4) = 0 Then
   byteswide = by8
Else
   byteswide = (Int(by8) + 4) - (Int(by8) Mod 4)
End If
totalbytes = numscans * byteswide
ReDim bitmaparray(1 To totalbytes)

'Set BITMAPINFO values to pass to GetDIBits function.
With bInfo
   .bmiHeader.biSize = Len(.bmiHeader)
   .bmiHeader.biWidth = bmpsrc.bmWidth
   .bmiHeader.biHeight = bmpsrc.bmHeight
   .bmiHeader.biPlanes = bmpsrc.bmPlanes
   .bmiHeader.biBitCount = bmpsrc.bmBitsPixel
   .bmiHeader.biCompression = BI_RGB
End With

success = GetDIBits(hdcMono, hbmpMono, 0, numscans, bitmaparray(1), bInfo, DIB_RGB_COLORS)

'bitmaparray should now contain bitmap bit data. Now create bitmap file header.
ReDim fileheader(1 To &H3E)
fileheader(1) = &H42 'B
fileheader(2) = &H4D 'M
lfilesize = UBound(fileheader) + UBound(bitmaparray)
fileheader(3) = lfilesize And 255
fileheader(4) = (lfilesize 256) And 255
fileheader(5) = (lfilesize 65536) And 255
fileheader(6) = (lfilesize 16777216) And 255
fileheader(11) = &H3E 'offset
fileheader(15) = &H28 'size of bitmapinfoheader
fileheader(19) = dxBlt And 255
fileheader(20) = (dxBlt 256) And 255
fileheader(21) = (dxBlt 65536) And 255
fileheader(22) = (dxBlt 16777216) And 255
fileheader(23) = dyBlt And 255
fileheader(24) = (dyBlt 256) And 255
fileheader(25) = (dyBlt 65536) And 255
fileheader(26) = (dyBlt 16777216) And 255
fileheader(27) = 1
fileheader(29) = 1
fileheader(35) = UBound(bitmaparray) And 255
fileheader(36) = (UBound(bitmaparray) 256) And 255
fileheader(37) = (UBound(bitmaparray) 65536) And 255
fileheader(38) = (UBound(bitmaparray) 16777216) And 255
fileheader(47) = 2
fileheader(51) = 2
fileheader(59) = &HFF
fileheader(60) = &HFF
fileheader(61) = &HFF

ff = FreeFile
Open destfile For Binary Access Write As #ff
   Put #ff, , fileheader
   Put #ff, , bitmaparray
Close #ff

' Clean up
Call SelectObject(hdcMono, hbmpOld)
Call DeleteDC(hdcMono)
Call DeleteObject(hbmpMono)
End Sub