# Native Code > برنامه نویسی در 6 VB > برنامه نویسی مرتبط با بازی و گرافیک در VB6 >  سیاه و سفید

## سعید قدیری مقدم

سلام
آیا راحی برای سیاه و سفید کردن عکس درون picturebox وجود داره؟

----------


## mahdi_farhani

بله وجود داره
با تابع BitBlt میتونی این کارو بکنی
توضیحات بشترو اگه خواستی برات بنویسم بگو تا بنویسم.

----------


## سعید قدیری مقدم

اقا چرا نمیخوام دستت درد نکنه  :flower:

----------


## mahdi_farhani

آق سعید این هم یک برنامه از BitBlt

'
'Chapter 1
'Image Processing with 8-bit bitmaps
'

Option Explicit

Private Declare Function GetDIBColorTable Lib "gdi32" &#40;ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pRGBQuad As RGBQUAD&#41; As Long
Private Declare Function SetDIBColorTable Lib "gdi32" &#40;ByVal hDC As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD&#41; As Long

Private Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type



Private Declare Function BitBlt Lib "gdi32" &#40;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&#41; As Long
Private Declare Function SelectObject Lib "gdi32" &#40;ByVal hDC As Long, ByVal hObject As Long&#41; As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" &#40;ByVal hDC As Long&#41; As Long
Private Declare Function DeleteDC Lib "gdi32" &#40;ByVal hDC As Long&#41; As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" &#40;ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long&#41; As Long
Private Declare Function DeleteObject Lib "gdi32" &#40;ByVal hObject As Long&#41; As Long
Private Declare Function GetTickCount Lib "kernel32" &#40;&#41; As Long

'Constants for the GenerateDC function
'**LoadImage Constants**
Const IMAGE_BITMAP As Long = 0
Const LR_LOADFROMFILE As Long = &amp;H10
Const LR_CREATEDIBSECTION As Long = &amp;H2000
Const LR_DEFAULTCOLOR As Long = &amp;H0
Const LR_COLOR As Long = &amp;H2
'****************************************
Private Declare Function GetBitmapBits Lib "gdi32" &#40;ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any&#41; As Long
Private Declare Function SetBitmapBits Lib "gdi32" &#40;ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any&#41; As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" &#40;ByVal hObject As Long, ByVal nCount As Long, lpObject As Any&#41; As Long

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

Dim DC As Long
Dim Bitmaphandle As Long
Dim bm As BITMAP
'Original colors
Dim OriginalTable&#40;1 To 256&#41; As RGBQUAD
'color tables
Dim GrayTable&#40;1 To 256&#41; As RGBQUAD
Dim RedTable&#40;1 To 256&#41; As RGBQUAD
Dim BlueTable&#40;1 To 256&#41; As RGBQUAD
Dim GreenTable&#40;1 To 256&#41; As RGBQUAD
Dim InvertTable&#40;1 To 256&#41; As RGBQUAD

'Dimensions
Const BitmapWidth As Long = 200
Const BitmapHeight As Long = 200

Private Sub cmdBlue_Click&#40;&#41;

SetDIBColorTable DC, 0, 256, BlueTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdBright_Click&#40;&#41;
Dim TempValue As Long
Dim I As Long
Dim BrightColorTable&#40;1 To 256&#41; As RGBQUAD
'Brightness Table
Dim BrightTable&#40;0 To 255&#41; As Byte

'Build brightness lookup table
For I = 0 To 255
    TempValue = I * Val&#40;txtBright.Text&#41;
    
    If TempValue > 255 Then
        BrightTable&#40;I&#41; = 255
    Else
        BrightTable&#40;I&#41; = TempValue
    End If
Next I

'Build the actual color table
For I = 1 To 256
    
    BrightColorTable&#40;I&#41;.rgbBlue = BrightTable&#40;OriginalTable&#40;I&#41;.rgbBlue&#  41;
    BrightColorTable&#40;I&#41;.rgbRed = BrightTable&#40;OriginalTable&#40;I&#41;.rgbRed&#4  1;
    BrightColorTable&#40;I&#41;.rgbGreen = BrightTable&#40;OriginalTable&#40;I&#41;.rgbGreen&  #41;

Next I

SetDIBColorTable DC, 0, 256, BrightColorTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdGray_Click&#40;&#41;

SetDIBColorTable DC, 0, 256, GrayTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdGreen_Click&#40;&#41;

SetDIBColorTable DC, 0, 256, GreenTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdInvert_Click&#40;&#41;

SetDIBColorTable DC, 0, 256, InvertTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdRed_Click&#40;&#41;

SetDIBColorTable DC, 0, 256, RedTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdRestore_Click&#40;&#41;

SetDIBColorTable DC, 0, 256, OriginalTable&#40;1&#41;

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub cmdRipple_Click&#40;&#41;
Dim ByteArray&#40;&#41; As Byte
Dim I As Long, J As Long
Dim TempValue As Long
Dim RippleTable&#40;&#41; As Byte
Dim OriginalBits&#40;&#41; As Byte

ReDim OriginalBits&#40;1 To bm.bmWidthBytes, 1 To bm.bmHeight&#41;

GetBitmapBits Bitmaphandle, bm.bmWidthBytes * bm.bmHeight, OriginalBits&#40;1, 1&#41;


'Dimension the ripple lookup table
ReDim RippleTable&#40;1 To BitmapWidth&#41;

'Build ripple table
For I = 1 To BitmapWidth
    TempValue = I + Sin&#40;I / 5&#41; * Val&#40;txtRipple.Text&#41;
    If TempValue > BitmapWidth Then
        RippleTable&#40;I&#41; = BitmapWidth
    ElseIf TempValue &lt; 1 Then
        RippleTable&#40;I&#41; = 1
    Else
        RippleTable&#40;I&#41; = TempValue
    End If
    
Next I

ReDim ByteArray&#40;1 To bm.bmWidthBytes, 1 To bm.bmHeight&#41;

For I = 1 To bm.bmWidthBytes
    For J = 1 To bm.bmHeight
        
        ByteArray&#40;I, J&#41; = OriginalBits&#40;I, RippleTable&#40;J&#41;&#41;
        
    Next J
Next I

SetBitmapBits Bitmaphandle, bm.bmWidthBytes * bm.bmHeight, ByteArray&#40;1, 1&#41;

BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy
Me.Refresh

'Reset the bits
SetBitmapBits Bitmaphandle, bm.bmWidthBytes * bm.bmHeight, OriginalBits&#40;1, 1&#41;

End Sub

Private Sub Form_Load&#40;&#41;

DC = GenerateDC&#40;App.Path &amp; "\bitmap1.bmp", Bitmaphandle&#41;

'Check if the bitmap is 8-bit
GetObjectAPI Bitmaphandle, Len&#40;bm&#41;, bm

If bm.bmBitsPixel &lt;> 8 Then 'not a usable format
    MsgBox "Must be an 8-bit bitmap"
    Unload Me
    Exit Sub
End If


'Save the original color table
GetDIBColorTable DC, 0, 256, OriginalTable&#40;1&#41;

'Create the gray color table, based on the original table
CreateColorTables

'draw the picture
BitBlt Me.hDC, 0, 0, BitmapWidth, BitmapHeight, DC, 0, 0, vbSrcCopy

Me.Refresh

End Sub

Private Sub CreateColorTables&#40;&#41;
Dim I As Long
Dim TempValue As Long

For I = LBound&#40;GrayTable&#41; To UBound&#40;GrayTable&#41;
        
    'Create Gray Color table
    'Add the values together
    TempValue = OriginalTable&#40;I&#41;.rgbBlue
    TempValue = TempValue + OriginalTable&#40;I&#41;.rgbGreen
    TempValue = TempValue + OriginalTable&#40;I&#41;.rgbRed
    
    'Get the medium value
    TempValue = TempValue / 3
    
    'Set the color in the gray table
    GrayTable&#40;I&#41;.rgbBlue = TempValue
    GrayTable&#40;I&#41;.rgbGreen = TempValue
    GrayTable&#40;I&#41;.rgbRed = TempValue
        
    'Create the rest of the color tables
    'Red Table
    RedTable&#40;I&#41;.rgbBlue = 0
    RedTable&#40;I&#41;.rgbGreen = 0
    RedTable&#40;I&#41;.rgbRed = OriginalTable&#40;I&#41;.rgbRed
    
    'Green Table
    GreenTable&#40;I&#41;.rgbBlue = 0
    GreenTable&#40;I&#41;.rgbRed = 0
    GreenTable&#40;I&#41;.rgbGreen = OriginalTable&#40;I&#41;.rgbGreen
    
    'Blue table
    BlueTable&#40;I&#41;.rgbBlue = OriginalTable&#40;I&#41;.rgbBlue
    BlueTable&#40;I&#41;.rgbGreen = 0
    BlueTable&#40;I&#41;.rgbRed = 0
    
    'invert table
    InvertTable&#40;I&#41;.rgbBlue = 255 - OriginalTable&#40;I&#41;.rgbBlue
    InvertTable&#40;I&#41;.rgbGreen = 255 - OriginalTable&#40;I&#41;.rgbGreen
    InvertTable&#40;I&#41;.rgbRed = 255 - OriginalTable&#40;I&#41;.rgbRed

Next I
    
End Sub

'IN&#58; FileName&#58; The file name of the graphics
'    BitmapHandle&#58; The receiver of the loaded bitmap handle
'OUT&#58; The Generated DC
Public Function GenerateDC&#40;FileName As String, ByRef Bitmaphandle As Long&#41; As Long
Dim DC As Long
Dim hBitmap As Long

'Create a Device Context, compatible with the screen
DC = CreateCompatibleDC&#40;0&#41;

If DC &lt; 1 Then
    GenerateDC = 0
    'Raise error
    Err.Raise vbObjectError + 1
    Exit Function
End If

'Load the image....BIG NOTE&#58; This function is not supported under NT, there you can not
'specify the LR_LOADFROMFILE flag
hBitmap = LoadImage&#40;0, FileName, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION&#41;

If hBitmap = 0 Then 'Failure in loading bitmap
    DeleteDC DC
    GenerateDC = 0
    'Raise error
    Err.Raise vbObjectError + 2
    Exit Function
End If

'Throw the Bitmap into the Device Context
SelectObject DC, hBitmap

'Return the device context and handle
Bitmaphandle = hBitmap
GenerateDC = DC

End Function
'Deletes a generated DC
Private Function DeleteGeneratedDC&#40;DC As Long&#41; As Long

If DC > 0 Then
    DeleteGeneratedDC = DeleteDC&#40;DC&#41;
Else
    DeleteGeneratedDC = 0
End If

End Function

Private Sub Form_Unload&#40;Cancel As Integer&#41;
'Clean Up
DeleteGeneratedDC DC
DeleteObject Bitmaphandle

End Sub

----------


## سعید قدیری مقدم

قربون دستت
 :) 
ای کاش برنامشو واسه دانلود میزاشتی  :wink: 
به هر حال ممنون

----------


## xxxxx_xxxxx

برای سیاه و سفید کردن یک تصویر، پیکسلها را خوانده و مقادیر RGB آنها را بدست می آوریم. میانگین RGB را به عنوان R و G و B در تصویر ذخیره می کنیم. زمانی که هر سه پارامتر R و G و B مقادیر یکسان یا نزدیک بهم داشته باشند ما با تصویری از طیف خاکستری روبرو خواهیم بود.

----------


## mehdizadeh62

سلام 
این کد رو برای سیاه وسفید کردن عکس نوشتم ولی هیچ اتفاقی نمی افته کسی میتونه راهنمایی کنه؟
Private Sub Command1_Click()
Dim xxx, yyy, pixel
Dim Bblue, Ggreen, Rred, temp
For yyy = 0 To Pic1.ScaleHeight - 1
For xxx = 0 To Pic1.ScaleWidth - 1
pixel = Pic1.Point(xxx, yyy)
Bblue = pixel \ (256 ^ 2)
    Ggreen = (pixel - Bblue * 256 ^ 2) \ 256
    Rred = (pixel - Bblue * 256 ^ 2 - Ggreen * 256)
 
temp = (Rred + Ggreen + Bblue)
temp = (temp / 3)
Pic1.PSet (xxx, yyy), RGB(temp, temp, temp)
Next
Pic1.Refresh
Next
Pic1.Refresh
End Sub

----------


## xxxxx_xxxxx

> سلام 
> این کد رو برای سیاه وسفید کردن عکس نوشتم ولی هیچ اتفاقی نمی افته کسی  میتونه راهنمایی کنه؟


سلام،
دستورات صحیح هستند، تنها خاصیت AutoRedraw تصویر رو True کنید و همچنین خاصیت ScaleMode رو برابر Pixel قرار بدید.

موفق باشید/

----------


## honarestani

> سلام 
> این کد رو برای سیاه وسفید کردن عکس نوشتم ولی هیچ اتفاقی نمی افته کسی میتونه راهنمایی کنه؟
> Private Sub Command1_Click()
> Dim xxx, yyy, pixel
> Dim Bblue, Ggreen, Rred, temp
> For yyy = 0 To Pic1.ScaleHeight - 1
> For xxx = 0 To Pic1.ScaleWidth - 1
> pixel = Pic1.Point(xxx, yyy)
> Bblue = pixel \ (256 ^ 2)
> ...



سلام.
خیلی خوبه این برنامه اما آیا میشه همین برنامه رو دستکاری کرد تا پیکسل ها فقط سیاه مطلق یا سفید مطلق بشن ؟ یعنی انواع خاکستری نباشه ؟
اگه هم باید خاکستری تبدیل به سفید شه یا سیاه ترجیح میدم به سیاه تبدیل شه
اگه میشه راهنمایی کنید یا بنویسید ممنون
 :لبخند گشاده!:

----------


## darya_a

> سلام،
> دستورات صحیح هستند، تنها خاصیت AutoRedraw تصویر رو True کنید و همچنین خاصیت ScaleMode رو برابر Pixel قرار بدید.
> 
> موفق باشید/


ممنون. لطف کردین. موفق باشید.

----------


## darya_a

> سلام 
> این کد رو برای سیاه وسفید کردن عکس نوشتم ولی هیچ اتفاقی نمی افته کسی میتونه راهنمایی کنه؟
> Private Sub Command1_Click()
> Dim xxx, yyy, pixel
> Dim Bblue, Ggreen, Rred, temp
> For yyy = 0 To Pic1.ScaleHeight - 1
> For xxx = 0 To Pic1.ScaleWidth - 1
> pixel = Pic1.Point(xxx, yyy)
> Bblue = pixel \ (256 ^ 2)
> ...


خیلی ممنون. لطف کردین. موفق باشید.

----------

