Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/impdes/dessin.bas

BASIC Source File | 1995-09-07 | 21.0 KB | 376 lines

'                                                                                                                                                                                                               '
'                                                                                                                                                                                                                '
'DΘfinition des types                                                                                                                                                                                             '
'                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                   '
    Option Explicit
    DefInt A-Z

    Type BITMAPINFOHEADER_Type
    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

    Type BITMAPINFO_Type
    BitmapInfoHeader As BITMAPINFOHEADER_Type
    bmiColors As String * 1024
    End Type

    Type RectType
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
    End Type
    Type PointType
    X As Integer
    Y As Integer
    End Type
'                                                                                                                                                                                                               '
'                                                                                                                                                                                                                '
'API                                                                                                                                                                                            '
'                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                   '
    Declare Function CreateCompatibleDC Lib "gdi" (ByVal hDC)
    Declare Function GetWindowDC Lib "user" (ByVal hWnd)
    Declare Function GetDC Lib "user" (ByVal hWnd)
    Declare Function ReleaseDC Lib "user" (ByVal hWnd, ByVal hDC)
    Declare Function DeleteDC Lib "gdi" (ByVal hDC)
    ' Graphics related API
    Declare Function BitBlt Lib "gdi" (ByVal hDC, ByVal X, ByVal Y, ByVal w, ByVal h, ByVal hDC, ByVal X, ByVal Y, ByVal o As Long)
    Declare Function GetDIBits Lib "gdi" (ByVal hDC, ByVal hBitmap, ByVal nStartScan, ByVal nNumScans, ByVal LpBits As Long, BitmapInfo As BITMAPINFO_Type, ByVal wUsage)
    Declare Function StretchDIBits Lib "gdi" (ByVal hDC, ByVal DestX, ByVal DestY, ByVal wDestWidth, ByVal wDestHeight, ByVal SrcX, ByVal SrcY, ByVal wSrcWidth, ByVal wSrcHeight, ByVal LpBits&, BitsInfo As BITMAPINFO_Type, ByVal wUsage, ByVal dwRop&)
    ' General attribute related API
    Declare Function GetDeviceCaps Lib "gdi" (ByVal hDC, ByVal nIndex)
    Declare Function GetWindowRect Lib "user" (ByVal hWnd, lpRect As RectType)
    Declare Function GetClientRect Lib "user" (ByVal hWnd, lpRect As RectType)
    ' Memory allocation related API
    Declare Function GlobalAlloc Lib "kernel" (ByVal wFlags, ByVal lMem&)
    Declare Function GlobalLock Lib "kernel" (ByVal HMem) As Long
    Declare Function GlobalUnlock Lib "kernel" (ByVal HMem)
    Declare Function GlobalFree Lib "kernel" (ByVal HMem)
    ' Graphics object related API
    Declare Function CreateCompatibleBitmap Lib "gdi" (ByVal hDC, ByVal nWidth, ByVal nHeight)
    Declare Function DeleteObject Lib "gdi" (ByVal hObject)
    Declare Function SelectObject Lib "gdi" (ByVal hDC, ByVal hObject)
    Declare Function ClientToScreen Lib "user" (ByVal hWnd, P As PointType)
    Declare Function LPToDP Lib "gdi" (ByVal hDC, P As PointType, ByVal nCount)
'                                                                                                                                                                                                               '
'                                                                                                                                                                                                                '
'DΘfinition des Global Constantes                                                                                                                                                                                             '
'                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                   '
    Global Const HORZRES = 8
    Global Const VERTRES = 10
    Global Const SRCCOPY = &HCC0020
    Global Const NEWFRAME = 1
    Global Const BITSPIXEL = 12
    Global Const PLANES = 14
    Global Const BI_RGB = 0
    Global Const BI_RLE8 = 1
    Global Const BI_RLE4 = 2
    Global Const DIB_PAL_COLORS = 1
    Global Const DIB_RGB_COLORS = 0
    Global Const GMEM_MOVEABLE = 2

Sub ImprimeGraphique (F As Form)
    Dim R As Integer
'                                                                                                                                                                                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                                                                                                                                                                '
'Cette procΘdure permet l'impression d'une fenΩtre                                                                                                                                                                                                                                                                                                                                                '
'                                                                                                                                                                                                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                                                                                                                                                   '
    Printer.ScaleMode = 3
    Screen.MousePointer = 11
    Printer.Print ""
    'Appel de la fonction                                                                                                                                                                                                                                                                                                                                                       '
    R = PrintWindow(Printer.hDC, 100, 100, Printer.ScaleWidth - 200, Printer.ScaleHeight - 200, F.hWnd)
    If Not R Then
    MsgBox "Unable to print the form"
    Else
    Printer.EndDoc
    End If
    Screen.MousePointer = 0
End Sub

Function PrintClient (ByVal hDC_Dest, ByVal DestX, ByVal DestY, ByVal hWnd_SrcWindow, Ratio As Integer)
'                                                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                                '
'ProcΘdure permettant l'impression d'un contr⌠le sur l'imprimante                                                                                                                                                                                                 '
'                                                                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                   '
    Dim Cr$
    Dim hDC_Window As Integer
    Dim HDC_Mem As Integer
    Dim R As Integer
    Dim Window_Width As Integer
    Dim Window_Height As Integer
    Dim R1 As Integer
    Dim R2 As Integer
    Dim ScreenWidth As Integer
    Dim screenHeight As Integer
    Dim HPrevBmp As Integer
    Dim HBMP_Window As Integer
    Dim Client_Width As Integer
    Dim Client_Height As Integer
    Dim XDiff As Integer
    Dim YDiff As Integer
    Dim HDC_MemClient As Integer
    Dim HBMP_Client As Integer
    Dim HBMPClientPrev As Integer
    Dim BitsPerPixel As Integer
    Dim ColorPlanes As Integer
    Dim WidthRatio!
    Dim HeightAspectRatio!
    Dim PrintWidth As Integer
    Dim PrintHeight As Integer
    Dim BytesNeeded&
    Dim HMem As Integer
    Dim LpBits&
    Dim R3 As Integer
    Dim Rect As RectType, RectClient As RectType
    Dim BitmapInfo As BITMAPINFO_Type
    Dim pWindow As PointType, pClient As PointType, pDiff As PointType
    Cr$ = Chr$(13)

    ' Get the DC for the entire window including the non-client area.
    hDC_Window = GetWindowDC(hWnd_SrcWindow)
    HDC_Mem = CreateCompatibleDC(hDC_Window)

    ' Get the pixel dimensions of the screen.
    ScreenWidth = GetDeviceCaps(hDC_Window, HORZRES)
    screenHeight = GetDeviceCaps(hDC_Window, VERTRES)

    ' Get the pixel dimensions of the window to be printed.
    R = GetWindowRect(hWnd_SrcWindow, Rect)
    Window_Width = Abs(Rect.Right - Rect.Left)
    Window_Height = Abs(Rect.Bottom - Rect.Top)

    ' Create a bitmap compatible with the window DC.
    HBMP_Window = CreateCompatibleBitmap(hDC_Window, Window_Width, Window_Height)

    ' Select the bitmap to hold the window image into the memory DC.
    HPrevBmp = SelectObject(HDC_Mem, HBMP_Window)

    ' Copy the image of the window to the memory DC.
    R1 = BitBlt(HDC_Mem, 0, 0, Window_Width, Window_Height, hDC_Window, 0, 0, SRCCOPY)

    ' Get the dimensions of the client area.
    R = GetClientRect(hWnd_SrcWindow, RectClient)
    Client_Width = Abs(RectClient.Right - RectClient.Left)
    Client_Height = Abs(RectClient.Bottom - RectClient.Top)

    ' Calculate the pixel difference (x and y) between the upper-left corner of the non-client area and the upper-left corner of the client area.
    pClient.X = RectClient.Left
    pClient.Y = RectClient.Top
    R = ClientToScreen(hWnd_SrcWindow, pClient)
    XDiff = Abs(pClient.X - Rect.Left)
    YDiff = Abs(pClient.Y - Rect.Top)

    ' Create a DC and bitmap to represent the client area of the window.
    HDC_MemClient = CreateCompatibleDC(hDC_Window)
    HBMP_Client = CreateCompatibleBitmap(hDC_Window, Client_Width, Client_Height)
    HBMPClientPrev = SelectObject(HDC_MemClient, HBMP_Client)

    ' Bitblt client area of window to memory bitmap representing the client area.
    R = BitBlt(HDC_MemClient, 0, 0, Client_Width, Client_Height, HDC_Mem, XDiff, YDiff, SRCCOPY)

    ' Reselect in the previous bitmap and select out the source image bitmap.
    R = SelectObject(HDC_Mem, HPrevBmp)

    ' Delete the DC a and bitmap associated with the window.
    R = DeleteDC(hDC_Window)
    R = DeleteObject(HBMP_Window)
    BitsPerPixel = GetDeviceCaps(HDC_MemClient, BITSPIXEL)
    ColorPlanes = GetDeviceCaps(HDC_MemClient, PLANES)
    BitmapInfo.BitmapInfoHeader.biSize = 40
    BitmapInfo.BitmapInfoHeader.biWidth = Client_Width
    BitmapInfo.BitmapInfoHeader.biHeight = Client_Height
    BitmapInfo.BitmapInfoHeader.biPlanes = 1
    BitmapInfo.BitmapInfoHeader.biBitCount = BitsPerPixel * ColorPlanes
    BitmapInfo.BitmapInfoHeader.biCompression = BI_RGB
    BitmapInfo.BitmapInfoHeader.biSizeImage = 0
    BitmapInfo.BitmapInfoHeader.biXPelsPerMeter = 0
    BitmapInfo.BitmapInfoHeader.biYPelsPerMeter = 0
    BitmapInfo.BitmapInfoHeader.biClrUsed = 0
    BitmapInfo.BitmapInfoHeader.biClrImportant = 0

    ' Calculate the ratios based on the source and destination devices. This will help to cause the size of the window image to
    ' be approximately the same proportion on another device such as a printer.
    PrintWidth = Ratio * Window_Width
    PrintHeight = Ratio * Window_Height
    ' Calculate the number of bytes needed to store the image assuming 8 bits/pixel.
    BytesNeeded& = CLng(Window_Width + 1) * (Window_Height + 1)

    ' Allocate a buffer to hold the bitmap bits.
    HMem = GlobalAlloc(GMEM_MOVEABLE, BytesNeeded&)
    If hDC_Window <> 0 And HBMP_Window <> 0 And hDC_Dest <> 0 And HMem <> 0 Then
    LpBits& = GlobalLock(HMem)
    ' Get the bits that make up the image and copy them to the
    ' destination device.
    R2 = GetDIBits(HDC_MemClient, HBMP_Client, 0, Client_Height, LpBits&, BitmapInfo, DIB_RGB_COLORS)
    R3 = StretchDIBits(hDC_Dest, DestX, DestY, PrintWidth, PrintHeight, 0, 0, Client_Width, Client_Height, LpBits&, BitmapInfo, DIB_RGB_COLORS, SRCCOPY)
    End If

    ' Select in the previous bitmap.
    R = SelectObject(HDC_MemClient, HBMPClientPrev)

    ' Release or delete DC's, memory and objects.
    R = GlobalUnlock(HMem)
    R = GlobalFree(HMem)
    R = DeleteDC(HDC_MemClient)
    R = DeleteObject(HBMP_Client)
    R = ReleaseDC(hWnd_SrcWindow, hDC_Window)

    ' Return true if the window was successfully printed.
    If R2 <> 0 And R3 <> 0 Then
    PrintClient = True
    Else
    PrintClient = False
    End If

End Function

Function PrintWindow (ByVal hDC_Dest, ByVal DestX, ByVal DestY, ByVal DestDevWidth, ByVal DestDevHeight, ByVal hWnd_SrcWindow)
'                                                                                                                                                                                                                                                               '
'                                                                                                                                                                                                                                                                '
'ProcΘdure permettant l'impression d'une fenΩtre sur l'imprimante                                                                                                                                                                                                 '
'                                                                                                                                                                                                                                                                  '
'                                                                                                                                                                                                                                                                   '
    Dim Rect As RectType
    Dim BitmapInfo As BITMAPINFO_Type
    Dim Ratio As Single
    Dim Cr$
    Dim hDC_Window As Integer
    Dim HDC_Mem As Integer
    Dim R As Integer
    Dim Window_Width As Integer
    Dim Window_Height As Integer
    Dim R1 As Integer
    Dim R2 As Integer
    Dim ScreenWidth As Integer
    Dim screenHeight As Integer
    Dim HPrevBmp As Integer
    Dim HBMP_Window As Integer
    Dim Client_Width As Integer
    Dim Client_Height As Integer
    Dim XDiff As Integer
    Dim YDiff As Integer
    Dim HDC_MemClient As Integer
    Dim HBMP_Client As Integer
    Dim HBMPClientPrev As Integer
    Dim BitsPerPixel As Integer
    Dim ColorPlanes As Integer
    Dim WidthRatio!
    Dim HeightAspectRatio!
    Dim PrintWidth As Integer
    Dim PrintHeight As Integer
    Dim BytesNeeded&
    Dim HMem As Integer
    Dim LpBits&
    Dim R3 As Integer
    Cr$ = Chr$(13)

    ' Get the DC for the entire window including the non-client area.
    hDC_Window = GetWindowDC(hWnd_SrcWindow)
    HDC_Mem = CreateCompatibleDC(hDC_Window)

    ' Get the pixel dimensions of the screen.  This is necessary so
    ' that we can determine the relative size of the window compared to

    ' the screen
    ScreenWidth = GetDeviceCaps(hDC_Window, HORZRES)
    screenHeight = GetDeviceCaps(hDC_Window, VERTRES)

    ' Get the pixel dimensions of the window to be printed.
    R = GetWindowRect(hWnd_SrcWindow, Rect)
    Window_Width = Abs(Rect.Right - Rect.Left)
    Window_Height = Abs(Rect.Bottom - Rect.Top)

    ' Create a bitmap compatible with the window DC.
    HBMP_Window = CreateCompatibleBitmap(hDC_Window, Window_Width, Window_Height)

    ' Select the bitmap to hold the window image into the memory DC.

    HPrevBmp = SelectObject(HDC_Mem, HBMP_Window)

    ' Copy the image of the window to the memory DC.
    R1 = BitBlt(HDC_Mem, 0, 0, Window_Width, Window_Height, hDC_Window, 0, 0, SRCCOPY)

    BitsPerPixel = GetDeviceCaps(HDC_Mem, BITSPIXEL)
    ColorPlanes = GetDeviceCaps(HDC_Mem, PLANES)

    BitmapInfo.BitmapInfoHeader.biSize = 40
    BitmapInfo.BitmapInfoHeader.biWidth = Window_Width
    BitmapInfo.BitmapInfoHeader.biHeight = Window_Height
    BitmapInfo.BitmapInfoHeader.biPlanes = 1
    BitmapInfo.BitmapInfoHeader.biBitCount = BitsPerPixel * ColorPlanes
    BitmapInfo.BitmapInfoHeader.biCompression = BI_RGB

    BitmapInfo.BitmapInfoHeader.biSizeImage = 0
    BitmapInfo.BitmapInfoHeader.biXPelsPerMeter = 0
    BitmapInfo.BitmapInfoHeader.biYPelsPerMeter = 0
    BitmapInfo.BitmapInfoHeader.biClrUsed = 0
    BitmapInfo.BitmapInfoHeader.biClrImportant = 0

    ' Calculate the ratios based on the source and destination
    ' devices. This will help to cause the size of the window image
    ' to be approximately the same proportion on another device
    ' such as a printer.
    WidthRatio! = DestDevWidth / Window_Width
    HeightAspectRatio! = DestDevHeight / Window_Height
    If WidthRatio! > HeightAspectRatio! Then Ratio = HeightAspectRatio!:  Else Ratio = WidthRatio!

    PrintWidth = Ratio * Window_Width
    PrintHeight = Ratio * Window_Height

    ' Calculate the number of bytes needed to store the image assuming
    ' 8 bits/pixel.

    BytesNeeded& = CLng(Window_Width + 1) * (Window_Height + 1)

    ' Allocate a buffer to hold the bitmap bits.
    HMem = GlobalAlloc(GMEM_MOVEABLE, BytesNeeded&)

    If hDC_Window <> 0 And HBMP_Window <> 0 And hDC_Dest <> 0 And HMem <> 0 Then

    LpBits& = GlobalLock(HMem)

    ' Get the bits that make up the image and copy them to the
    ' destination device.
    R2 = GetDIBits(HDC_Mem, HBMP_Window, 0, Window_Height, LpBits&, BitmapInfo, DIB_RGB_COLORS)

    R3 = StretchDIBits(hDC_Dest, DestX, DestY, PrintWidth, PrintHeight, 0, 0, Window_Width, Window_Height, LpBits&, BitmapInfo, DIB_RGB_COLORS, SRCCOPY)
    End If

    ' Reselect in the previous bitmap and select out the source
    ' image bitmap.
    R = SelectObject(HDC_Mem, HPrevBmp)

    ' Release or delete DC's, memory and objects.
    R = GlobalUnlock(HMem)
    R = GlobalFree(HMem)
    R = DeleteDC(hDC_Window)
    R = DeleteObject(HBMP_Window)
    R = ReleaseDC(hWnd_SrcWindow, hDC_Window)


    ' Return true if the window was successfully printed.
    If R2 <> 0 And R3 <> 0 Then
    PrintWindow = True
    Else
    PrintWindow = False
    End If

End Function