Udskrivning af picturebox el. shape?!?

h

Hej carik!
På den her måde kan du selv vælge hvilket af formen du vil printe - bare set størrelsen af pictureboxen til at være samme som billedet.

Example of Using a PictureBox to Print a Form in Any Orientation
Create a new Standard EXE Project. Form1 is created by default.


Add two PictureBoxes to Form1 so that each nearly covers the Form.

NOTE: Avoid drawing the second PictureBox within the first. Doing so makes the second PictureBox a member of the first. A simple way to avoid the problem is to place the origin point of the second PictureBox to the left of the origin point of the first PictureBox. Once the second box is drawn, you can resize it so that it is the same size as the first PictureBox.


Right-mouse click on Picture2 and choose \"Send to Back.\"


Place Picture1 on top of Picture2, covering Picture2.


Add a CommandButton and some other controls to Picture1, leaving Picture2 empty.


Place this code in the Declarations Section of the module of the Form:

      Private Declare Function SendMessage Lib \"user32\" Alias _
        \"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long

      Private Const WM_PAINT = &HF
      Private Const WM_PRINT = &H317
      Private Const PRF_CLIENT = &H4&    \' Draw the window\'s client area
      Private Const PRF_CHILDREN = &H10& \' Draw all visible child windows
      Private Const PRF_OWNED = &H20&    \' Draw all owned windows

      Private Sub Command1_Click()
      Dim rv As Long
      Picture1.SetFocus  \' So that the button doesn\'t look pressed
      Picture2.AutoRedraw = True
      rv = SendMessage(Picture1.hwnd, WM_PAINT, Picture2.hDC, 0)
      rv = SendMessage(Picture1.hwnd, WM_PRINT, Picture2.hDC, _
          PRF_CHILDREN + PRF_CLIENT + PRF_OWNED)
      Picture2.Picture = Picture2.Image
      Picture2.AutoRedraw = False
      Printer.Orientation = vbPRORLandscape  \' 2
      Printer.Print \"\"
      Printer.PaintPicture Picture2.Picture, 0, 0
      Printer.EndDoc
      Command1.SetFocus  \' Return Focus
      End Sub

      Private Sub Form_Load()
      Me.Show
      Command1.Caption = \"Print Form\"
      End Sub




Run the Project and click on the \"Print Form\" button. Note that when you click on Command1, \"Print Form\", it will print the PictureBox and the controls it contains in Landscape orientation.

Hej igen!
Der er også en måde hvor du via API kan vælge at udskrive indholdet i en PictureBox. Den eneste udlempe er den store mængde kode!:

1. Start a new project in Visual Basic. Form1 is created by default.


2. Add a picture box (Picture1) and a Command button (Command1) to the form.


3. Place the following code in the Command button\'s click event:

  Sub Command1_Click ()
      \' Set up picture box (these properties can be set at design time):
      Picture1.AutoRedraw = True      \' Must be true if invisible.
      Picture1.ScaleMode = PIXELS      \' Scale mode must be pixels.
      Picture1.AutoSize = True
      Picture1.Visible = False
      Picture1.Picture = LoadPicture(\"C:\\WINDOWS\\256COLOR.BMP\")

      \' Set up Printer object:
      Printer.ScaleMode = PIXELS      \' Scale mode must be pixels.
      Printer.Print \" \"                \' Printer must be initialized.

      \' The source coordinates used must be valid for the picture. You can
      \' use Picture1.ScaleWidth and Picture1.ScaleHeight to verify them.
      \' All coordinates are in pixels.
      \' The coordinates 0, 0, 60, 40 are valid for 256COLOR.BMP.
      On Error Resume Next
      \' Enter the following two lines on one line:
      Call StretchPicToDC(CInt(Printer.hDC), 0, 0, 600, 400, Picture1, 0,
        0, 60, 40)
      If Err Then
        MsgBox Err & \": Error Printing Picture\"
        \' Predefined error codes are commented in the BAS file.
      End If
      On Error Goto 0

      \' End print job:
      Printer.EndDoc
  End Sub




Add a new module to the project.


Place the following code in the new module:

  Option Explicit

  Type BITMAPINFOHEADER
      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
      bmiHeader As BITMAPINFOHEADER
      bmiColors As String * 1024 \' Enough for 256 colors.
  End Type

  Global Const PIXELS = 3
  Global Const SRCCOPY = &HCC0020
  Global Const BI_RGB = 0
  Global Const DIB_RGB_COLORS = 0
  Global Const GMEM_MOVEABLE = 2
  Global Const RASTERCAPS = 38
  Global Const RC_STRETCHDIB = &H2000
  Global Const RC_PALETTE = &H100
  Global Const PLANES = 14
  Global Const BITSPIXEL = 12
  Global Const SIZEPALETTE = 104
  Global Const VBM_GETPALETTE = &H101C

  \' Each of the following declares should be entered on one line:
  Declare Function CreateCompatibleDC Lib \"GDI\" (ByVal hDC As Integer
      ) As Integer
  Declare Function DeleteDC Lib \"GDI\" (ByVal hDC As Integer) As Integer
  Declare Function BitBlt Lib \"GDI\" (ByVal hDCDest As Integer,
      ByVal XDest As Integer, ByVal YDest As Integer, ByVal nWidth As
  Integer,
      ByVal nHeight As Integer, ByVal hDCSrc As Integer, ByVal XSrc As
  Integer,
      ByVal YSrc As Integer, ByVal dwROP As Long) As Integer
  Declare Function CreateCompatibleBitmap Lib \"GDI\" (ByVal hDC As Integer,
      ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
  Declare Function DeleteObject Lib \"GDI\" (ByVal hObject As Integer) As
  Integer
  Declare Function SelectObject Lib \"GDI\" (ByVal hDC As Integer,
      ByVal hObject As Integer) As Integer
  Declare Function GetDIBits Lib \"GDI\" (ByVal hDC As Integer,
      ByVal hBitmap As Integer, ByVal nStartScan As Integer,
      ByVal nNumScans As Integer, ByVal lpBits As Long,
      BITMAPINFO As BITMAPINFO, ByVal wUsage As Integer) As Integer
  Declare Function StretchDIBits Lib \"GDI\" (ByVal hDC As Integer,
      ByVal DestX As Integer, ByVal DestY As Integer,
      ByVal wDestWidth As Integer, ByVal wDestHeight As Integer,
      ByVal SrcX As Integer, ByVal SrcY As Integer, ByVal wSrcWidth As
  Integer,
      ByVal wSrcHeight As Integer, ByVal lpBits As Long, BitsInfo As
  BITMAPINFO,
      ByVal wUsage As Integer, ByVal dwRop As Long) As Integer
  Declare Function GetDeviceCaps Lib \"GDI\" (ByVal hDC As Integer,
      ByVal iCapabilitiy As Integer) As Integer

  Declare Function GlobalAlloc Lib \"KERNEL\" (ByVal wFlags As Integer,
      ByVal lMem As Long) As Integer
  Declare Function GlobalLock Lib \"KERNEL\" (ByVal hMem As Integer) As Long
  Declare Function GlobalUnlock Lib \"KERNEL\" (ByVal hMem As Integer) As
      Integer
  Declare Function GlobalFree Lib \"KERNEL\" (ByVal hMem As Integer) As
      Integer

  Declare Function SelectPalette Lib \"USER\" (ByVal hDC As Integer,
      ByVal hPalette As Integer, ByVal bForceBackground As Integer) As
      Integer
  Declare Function RealizePalette Lib \"USER\" (ByVal hDC As Integer) As
      Integer
  Declare Function SendMessage Lib \"USER\" (ByVal hWnd As Integer,
      ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As
  Long

  \' The following are Global constants for the error trapping comments
  \' below:

  Global Const ERR_PICSCALEMODE = 11100
  \' Picture box ScaleMode not Pixels
  Global Const ERR_PICAUTOREDRAW = 11101
  \' Picture invisible and AutoRedraw False
  Global Const ERR_SRCPARAMETER = 11102
  \' Source coordinates out of range
  Global Const ERR_PRINTERSCALEMODE = 11103
  \' Printer ScaleMode not Pixels
  Global Const ERR_DESTPARAMETER = 11104
  \' Destination coordinates out of range
  Global Const ERR_DEVSTRETCHDIB = 11105
  \' Device not supporting StretchDIBits
  Global Const ERR_PALSIZE = 11106
  \' Palette not 256 colors
  Global Const ERR_CREATEMEMDC = 11107
  \' Unable to create device context
  Global Const ERR_CREATEBMP = 11108
  \' Unable to create bitmap
  Global Const ERR_GETPALETTE = 11109
  \' Unable to retrieve palette
  Global Const ERR_BITBLT = 11110
  \' Unable to copy bitmap to memory
  Global Const ERR_BITMEM = 11111
  \' Unable to allocate memory for DIB bits
  Global Const ERR_LOCKBITMEM = 11112
  \' Unable to lock DIB bits memory
  Global Const ERR_GETDIB = 11113
  \' Unable to get DIB bits
  Global Const ERR_STRETCHDIB = 11114
  \' Unable to copy bitmap to destination
  Global Const ERR_UNLOCKMEM = 11115
  \' Unable to unlock DIB bits memory
  Global Const ERR_FREEMEM = 11116
  \' Unable to free DIB bits memory
  Global Const ERR_SELPAL = 11117
  \' Unable to select palette
  Global Const ERR_DELBMP = 11118
  \' Unable to delete bitmap
  Global Const ERR_DELMEMDC = 11119
  \' Unable to delete device context

  \'-----------------------------------------------------------------------
  \' StretchPicToDC:
  \'  - Stretches a specified portion of picture box to a device context.
  \'  - Works with 256-color bitmaps.
  \'  - Works on PostScript and PCL printers (driver must support
        StretchDIBits).
  \'  - Can output to other device contexts.
  \'
  \' hDCDest:
  \'  - This is destination device context.
  \'  - ScaleMode of device context must be pixels.
  \'  - If using Printer object, the printer should be initialized. This
  \'    can be accomplished with Printer.Print \" \" or any other printing.
  \'
  \' LeftDest, TopDest, WidthDest, and HeightDest describe the location and
  \' size of the image on the printer in pixels.
  \'
  \' picSrc:
  \'  - Is a picture box that must have ScaleMode = Pixels.
  \'  - Can also have Visible = False if AutoRedraw = True
  \'
  \' LeftSrc, TopSrc, WidthSrc, and HeightSrc describe the location and
  \' size of the source image in pixels.
  \'
  \' Errors will occur with a predefined code if necessary.
  \'
  \'-----------------------------------------------------------------------
  \' The following should be entered on one line:
  Sub StretchPicToDC (hDCDest As Integer, LeftDest, TopDest, WidthDest,
    HeightDest, picSrc As PictureBox, LeftSrc, TopSrc, WidthSrc,
    HeightSrc)

    Dim BMI As BITMAPINFO
    Dim hMem As Integer
    Dim lpBits As Long
    Dim r As Integer
    Dim hDCMemory As Integer
    Dim hBmp As Integer
    Dim hBmpPrev As Integer
    Dim hPal As Integer
    Dim hPalPrev As Integer

    Dim RasterCapsDest As Integer
    Dim RasterCapsSrc As Integer
    Dim HasPaletteSrc As Integer
    Dim BitsPixelSrc As Integer
    Dim PlanesSrc As Integer
    Dim PaletteSizeSrc As Integer

    \' Set error trap.
    On Error GoTo SPTDC_ERRORS:
    \' As a precaution, check for some invalid parameters.
    If picSrc.ScaleMode <> PIXELS Then Error ERR_PICSCALEMODE
    If picSrc.Visible = False And picSrc.AutoRedraw = False Then
        Error ERR_PICAUTOREDRAW
    End If
    If LeftSrc < 0 Or TopSrc < 0 Then Error ERR_SRCPARAMETER
    If WidthSrc <= 0 Or HeightSrc <= 0 Then Error ERR_SRCPARAMETER
    If LeftSrc > picSrc.ScaleWidth Then Error ERR_SRCPARAMETER
    If TopSrc > picSrc.ScaleHeight Then Error ERR_SRCPARAMETER
    If LeftSrc + WidthSrc > picSrc.ScaleWidth Then Error ERR_SRCPARAMETER
    If TopSrc + HeightSrc > picSrc.ScaleHeight Then Error ERR_SRCPARAMETER
    If LeftDest < 0 Or TopDest < 0 Then Error ERR_DESTPARAMETER
    If WidthDest <= 0 Or HeightDest <= 0 Then Error ERR_DESTPARAMETER
    If Printer.hDC = hDCDest Then
        If Printer.ScaleMode <> PIXELS Then Error ERR_PRINTERSCALEMODE
        If LeftDest > Printer.ScaleWidth Then Error ERR_DESTPARAMETER
        If TopDest > Printer.ScaleHeight Then Error ERR_DESTPARAMETER
        If LeftDest + WidthDest > Printer.ScaleWidth Then
          Error ERR_DESTPARAMETER
        End If
        If TopDest + HeightDest > Printer.ScaleHeight Then
          Error ERR_DESTPARAMETER
        End If
    End If

    \' Check that the destination supports StretchDIBits.
    RasterCapsDest = GetDeviceCaps(hDCDest, RASTERCAPS)
    If (RasterCapsDest And RC_STRETCHDIB) <> RC_STRETCHDIB Then
        Error ERR_DEVSTRETCHDIB
    End If
      \' Get properties of source device context.
    RasterCapsSrc = GetDeviceCaps(picSrc.hDC, RASTERCAPS)
    HasPaletteSrc = RasterCapsSrc And RC_PALETTE
    BitsPixelSrc = GetDeviceCaps(picSrc.hDC, BITSPIXEL)
    PlanesSrc = GetDeviceCaps(picSrc.hDC, PLANES)
    PaletteSizeSrc = GetDeviceCaps(picSrc.hDC, SIZEPALETTE)

    \' Limit function use to 256-color palettes.
    If HasPaletteSrc And (PaletteSizeSrc <> 256) Then Error ERR_PALSIZE
      \' Copy source to a bitmap in memory.
    hDCMemory = CreateCompatibleDC(picSrc.hDC)
    If hDCMemory = 0 Then Error ERR_CREATEMEMDC
    hBmp = CreateCompatibleBitmap(picSrc.hDC, WidthSrc, HeightSrc)
    If hBmp = 0 Then Error ERR_CREATEBMP
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    \' Get a copy of the source palette and realize it if necessary.
    If HasPaletteSrc Then
        hPal = SendMessage(picSrc.hWnd, VBM_GETPALETTE, 0, 0)
        If hPal = 0 Then Error ERR_GETPALETTE
        \' Select the palette into the destination and realize it.
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        r = RealizePalette(hDCMemory)
    End If
    \' Enter the following on one line:
    r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, picSrc.hDC, LeftSrc,
        TopSrc, SRCCOPY)
    If r = 0 Then Error ERR_BITBLT
    hBmp = SelectObject(hDCMemory, hBmpPrev)
      \' Fill in necessary parts of bitmap info.
    BMI.bmiHeader.biSize = 40
    BMI.bmiHeader.biWidth = WidthSrc
    BMI.bmiHeader.biHeight = HeightSrc
    BMI.bmiHeader.biPlanes = 1
    If BitsPixelSrc * PlanesSrc = 24 Then
        \' 24-bit True color may require too much memory, so
        \' limit to 256-color DIB.
        \' You can get rid of this exception and the routine
        \' should copy 24-bit color bitmaps.
        BMI.bmiHeader.biBitCount = 8 \' 8 bits = 256 colors
    Else
        BMI.bmiHeader.biBitCount = BitsPixelSrc * PlanesSrc
    End If
    BMI.bmiHeader.biCompression = BI_RGB

    \' Allocate memory for bitmap bits.
    \' Enter the following on one line:
    hMem = GlobalAlloc(GMEM_MOVEABLE, (CLng(WidthSrc *
        BMI.bmiHeader.biBitCount + 31) \\ 32) * 4 * HeightSrc)
    If hMem = 0 Then Error ERR_BITMEM
    lpBits = GlobalLock(hMem)
    \' Get the bits and color information from the persistent bitmap.
    \' The following should be entered on one line:
    r = GetDIBits(hDCMemory, hBmp, 0, HeightSrc, lpBits, BMI,
        DIB_RGB_COLORS)
    If r = 0 Then Error ERR_GETDIB

    \' Stretch the DIB to the printer.
    \' The following should be entered on one line:
    r = StretchDIBits(hDCDest, LeftDest, TopDest, WidthDest, HeightDest,
          0, 0, WidthSrc, HeightSrc, lpBits, BMI, DIB_RGB_COLORS, SRCCOPY)
    If r = 0 Then Error ERR_STRETCHDIB

    \' Free up memory used for bitmap bits.
    r = GlobalUnlock(hMem)
    If r <> 0 Then Error ERR_UNLOCKMEM
    r = GlobalFree(hMem)
    If r <> 0 Then Error ERR_FREEMEM

    \' Select the default palette back if necessary.
    If HasPaletteSrc Then
        r = SelectPalette(hDCMemory, hPalPrev, 0)
        If r = 0 Then Error ERR_SELPAL
    End If

    \' Delete created objects.
    r = DeleteObject(hBmp)
    If r = 0 Then Error ERR_DELBMP
    r = DeleteDC(hDCMemory)
    If r = 0 Then Error ERR_DELMEMDC

    On Error GoTo 0
  Exit Sub

  \' Clean up on predefined errors if necessary.
  SPTDC_ERRORS:
      Select Case Err
        Case ERR_CREATEBMP
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_GETPALETTE
            hBmp = SelectObject(hDCMemory, hBmpPrev)
            r = DeleteObject(hBmp)
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_BITBLT
            If HasPaletteSrc Then
              r = SelectPalette(hDCMemory, hPalPrev, 0)
            End If
            hBmp = SelectObject(hDCMemory, hBmpPrev)
            r = DeleteObject(hBmp)
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_BITMEM
            If HasPaletteSrc Then
              r = SelectPalette(hDCMemory, hPalPrev, 0)
            End If
            r = DeleteObject(hBmp)
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_GETDIB, ERR_STRETCHDIB
            r = GlobalUnlock(hMem)
            r = GlobalFree(hMem)
            If HasPaletteSrc Then
              r = SelectPalette(hDCMemory, hPalPrev, 0)
            End If
            r = DeleteObject(hBmp)
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_UNLOCKMEM, ERR_FREEMEM
            If HasPaletteSrc Then
              r = SelectPalette(hDCMemory, hPalPrev, 0)
            End If
            r = DeleteObject(hBmp)
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_SELPAL
            r = DeleteObject(hBmp)
            r = DeleteDC(hDCMemory)
            Error Err
        Case ERR_DELBMP
            r = DeleteDC(hDCMemory)
            Error Err
        Case Else
            Error Err
      End Select
      Error Err

  End Sub



Save the project.


Run the program (or press the F5 key). Then choose the Command1 button. The picture box should disappear and a portion of the hidden 256-color bitmap should be printed on the printer.


Notes
To print the entire picture box, specify 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight for the LeftSrc, TopSrc, WidthSrc, and HeightSrc parameters in the call to StretchPicToDC.


The extents of the printer are in the Printer.ScaleWidth and Printer.ScaleHeight properties. You can use this information to scale your output to the position and size you want.


To maintain an aspect ratio, you need to use the TwipsPerPixelX and TwipsPerPixelY properties of the Screen and Printer objects. For example, the printer image will have the same proportions as the screen image if you calculate the size in pixels with the following formulas:

      PrntHeight=ScrnHeight*(Screen.TwipsPerPixelY /
        Printer.TwipsPerPixelY)
      PrntWidth=ScrnWidth*(Screen.TwipsPerPixelX / Printer.TwipsPerPixelX)




If you want to print the nonvisible portion of a visible picture box, copy the contents into an invisible picture box with AutoSize set to True. Then print the picture in the invisible picture box.


The PrintPicToDC function does not work with negative values. PrintPicToDC will not print if it finds the coordinates invalid.


This method does not print child controls

Tak for koden - men findes der ikke en enkelt kommando der kan klare problemet. f.eks.:
shape1.print
eller sådan noget

hej Hvis koden skal være simpel kan du vel nøjes med at skrive:
Printer.Print \"\"
Printer.PaintPicturePicture1.Picture,0,0,Picture1.Width,Picture1.Height
Printer.EndDoc