dcsimg
Results 1 to 2 of 2

Thread: Drawing images

  1. #1

    Thread Starter
    Member
    Join Date
    Oct 2000
    Location
    chennai,india
    Posts
    44

    Drawing images

    Hi
    How can i draw an image over an existing image using VB?. I need to mark a particular portion on the image.

    How can i do it


    Regards
    sundar

  2. #2
    jim mcnamara
    Guest
    You use the BitBlt api call to move pixels from a region of one hDC to a specified region in another hDC (image)

    Since the destination area will be just a small fraction of the image, coinsider using StretchBlt.

    When you have to shrink the new image use StretchBlt - which does what BitBlt does, but resizes the new image

    Here is sample code for StrechBlt.
    Code:
    'This project needs:
    '- two picture boxes
    '- a button
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    
    Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long
    Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
    Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
    Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
    
    Const ScrCopy = &HCC0020
    Const Yellow = &HFFFF&
    Private Sub Form_Load()
        'KPD-Team 1998
        'URL: http://www.allapi.net/
        'E-Mail: KPDTeam@Allapi.net
        Dim Cnt1 As Byte, Cnt2 As Byte, Point As POINTAPI
        'Set the graphic mode to persistent
        Me.AutoRedraw = True
        'API uses pixels
        Me.ScaleMode = vbPixels
        Picture1.ScaleMode = vbPixels
        Picture2.ScaleMode = vbPixels
        'No borders
        Picture1.BorderStyle = 0: Picture2.BorderStyle = 0
        'Set the button's caption
        Command1.Caption = "Paint && Stretch"
        'Set the graphic mode to 'non persistent'
        Picture1.AutoRedraw = False: Picture2.AutoRedraw = False
        For Cnt1 = 0 To 100 Step 3
            For Cnt2 = 0 To 100 Step 3
                'Set the start-point's co÷rdinates
                Point.X = Cnt1: Point.Y = Cnt2
                'Move the active point
                MoveToEx Me.hdc, Cnt1, Cnt2, Point
                'Draw a line from the active point to the given point
                LineTo Me.hdc, 200, 200
            Next Cnt2
        Next Cnt1
        For Cnt1 = 0 To 100 Step 5
            For Cnt2 = 0 To 100 Step 5
                'Draw a pixel
                SetPixel Me.hdc, Cnt1, Cnt2, Yellow
            Next Cnt2
        Next Cnt1
    End Sub
    Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim XX As Long, YY As Long, A As Long
        XX = X: YY = Y
        'Set the picturebox' backcolor
        Picture2.BackColor = GetPixel(Picture1.hdc, XX, YY)
    End Sub
    Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If Button = 1 Then
            Dim XX As Long, YY As Long, A As Long
            XX = X: YY = Y
            'Set the picturebox' backcolor
            Picture2.BackColor = GetPixel(Picture1.hdc, XX, YY)
        End If
    End Sub
    Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
        Dim XX As Long, YY As Long, A As Long
        XX = X: YY = Y
        'Set the picturebox' backcolor
        Picture2.BackColor = GetPixel(Picture1.hdc, XX, YY)
    End Sub
    Private Sub Command1_Click()
        'Set the width and height
        Picture2.Width = 100: Picture2.Height = 100
        Picture1.Width = 50: Picture1.Height = 50
        'No pictures
        Picture1.Picture = LoadPicture("")
        DoEvents
        Copy the desktop to our picturebox
        PaintDesktop Picture1.hdc
        'Stretch the picture
        StretchBlt Picture2.hdc, 0, 0, 100, 100, Picture1.hdc, 0, 0, 50, 50, ScrCopy
    End Sub
    
    -----------------------------------------------------------------------------
    sample for BitBlt
    
    'used with fnWeight
    Const FW_DONTCARE = 0
    Const FW_THIN = 100
    Const FW_EXTRALIGHT = 200
    Const FW_LIGHT = 300
    Const FW_NORMAL = 400
    Const FW_MEDIUM = 500
    Const FW_SEMIBOLD = 600
    Const FW_BOLD = 700
    Const FW_EXTRABOLD = 800
    Const FW_HEAVY = 900
    Const FW_BLACK = FW_HEAVY
    Const FW_DEMIBOLD = FW_SEMIBOLD
    Const FW_REGULAR = FW_NORMAL
    Const FW_ULTRABOLD = FW_EXTRABOLD
    Const FW_ULTRALIGHT = FW_EXTRALIGHT
    'used with fdwCharSet
    Const ANSI_CHARSET = 0
    Const DEFAULT_CHARSET = 1
    Const SYMBOL_CHARSET = 2
    Const SHIFTJIS_CHARSET = 128
    Const HANGEUL_CHARSET = 129
    Const CHINESEBIG5_CHARSET = 136
    Const OEM_CHARSET = 255
    'used with fdwOutputPrecision
    Const OUT_CHARACTER_PRECIS = 2
    Const OUT_DEFAULT_PRECIS = 0
    Const OUT_DEVICE_PRECIS = 5
    'used with fdwClipPrecision
    Const CLIP_DEFAULT_PRECIS = 0
    Const CLIP_CHARACTER_PRECIS = 1
    Const CLIP_STROKE_PRECIS = 2
    'used with fdwQuality
    Const DEFAULT_QUALITY = 0
    Const DRAFT_QUALITY = 1
    Const PROOF_QUALITY = 2
    'used with fdwPitchAndFamily
    Const DEFAULT_PITCH = 0
    Const FIXED_PITCH = 1
    Const VARIABLE_PITCH = 2
    'used with SetBkMode
    Const OPAQUE = 2
    Const TRANSPARENT = 1
    
    Const LOGPIXELSY = 90
    Const COLOR_WINDOW = 5
    Const Message = "Hello !"
    
    Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
    
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex 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 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 GetDC Lib "user32" (ByVal hWnd 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 CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
    Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
    Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
    Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Dim mDC As Long, mBitmap As Long
    Private Sub Form_Click()
        Unload Me
    End Sub
    Private Sub Form_Load()
        'KPD-Team 1999
        'URL: http://www.allapi.net/
        'E-Mail: KPDTeam@Allapi.net
        Dim mRGN As Long, Cnt As Long, mBrush As Long, R As RECT
        'Create a device context, compatible with the screen
        mDC = CreateCompatibleDC(GetDC(0))
        'Create a bitmap, compatible with the screen
        mBitmap = CreateCompatibleBitmap(GetDC(0), Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)
        'Select the bitmap nito the device context
        SelectObject mDC, mBitmap
        'Set the bitmap's backmode to transparent
        SetBkMode mDC, TRANSPARENT
        'Set the rectangles' values
        SetRect R, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY
        'Fill the rect with the default window-color
        FillRect mDC, R, GetSysColorBrush(COLOR_WINDOW)
    
        For Cnt = 0 To 350 Step 30
            'Select the new font into the form's device context and delete the old font
            DeleteObject SelectObject(mDC, CreateMyFont(24, Cnt))
            'Print some text
            TextOut mDC, (Me.Width / Screen.TwipsPerPixelX) / 2, (Me.Height / Screen.TwipsPerPixelY) / 2, Message, Len(Message)
        Next Cnt
    
        'Create an elliptical region
        mRGN = CreateEllipticRgn(0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY)
        'Set the window region
        SetWindowRgn Me.hWnd, mRGN, True
    
        'delete our elliptical region
        DeleteObject mRGN
    End Sub
    Function CreateMyFont(nSize As Integer, nDegrees As Long) As Long
        'Create a specified font
        CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDC(0), LOGPIXELSY), 72), 0, nDegrees * 10, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, "Times New Roman")
    End Function
    Private Sub Form_Paint()
        'Copy the picture to the form
        BitBlt Me.hdc, 0, 0, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, mDC, 0, 0, vbSrcCopy
    End Sub
    Private Sub Form_Unload(Cancel As Integer)
        'clean up
        DeleteDC mDC
        DeleteObject mBitmap
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width