Matew писал(а):Скачал пример, прописал библиотеку, но пример не работает(( Рисует на форме символы. Пользоваться библиотекой в моих целях у меня не получается, т.ч. пример бы очень пригодился.
Option Explicit
' This function shows how you can use the API to obtain
' a printer device context for printing.
' Note how this function also switches to print in
' landscape mode without changing the default printer
' configuration.
'
Private Sub CmdPrint_Click()
Dim DeviceName$
Dim dm As DEVMODE, dmout As DEVMODE
Dim bufsize&
Dim dmInBuf() As Byte
Dim dmOutBuf() As Byte
Dim prhdc&
Dim dinfo As DOCINFO
Dim docname$
Dim oldcursor&
Dim hPrinter&
Dim res&, di&
hPrinter = OpenDefaultPrinter(DeviceName$)
' Get a copy of the DEVMODE structure for this printer
' First find out how big the DEVMODE structure is
bufsize& = DocumentProperties(hwnd, hPrinter, DeviceName$, 0, 0, 0)
' Allocate buffers of that size
ReDim dmInBuf(bufsize&)
ReDim dmOutBuf(bufsize&)
' Get the output DEVMODE structure
res = DocumentProperties(hwnd, hPrinter, DeviceName$, agGetAddressForObject(dmOutBuf(0)), agGetAddressForObject(dmInBuf(0)), DM_OUT_BUFFER)
' Copy the data buffer into the DEVMODE structure
agCopyData dmOutBuf(0), dmout, Len(dmout)
' Set the orientation, and set the dmField flag so that
' the function will know that it is valid.
dmout.dmOrientation = DMORIENT_LANDSCAPE
dmout.dmFields = dm.dmFields Or DM_ORIENTATION
' Now copy the data back to the buffer
agCopyData dmout, dmOutBuf(0), Len(dmout)
' We now have need DC to the default printer
' This DC is also initialized to landscape mode
prhdc = CreateDCBynum("WINSPOOL", DeviceName$, vbNullString, agGetAddressForObject&(dmOutBuf(0)))
If prhdc = 0 Then GoTo cleanup2
' The DOCINFO structure is the information that the
' print manager will show. This also gives you the
' opportunity of dumping output to a file.
docname$ = "Sample Document"
dinfo.cbSize = Len(dinfo)
dinfo.lpszDocName = docname$
dinfo.lpszOutput = vbNullString
Enabled = False ' Disable the main form
' The usual print sequence here
di = StartDoc(prhdc, dinfo)
di = StartPage(prhdc)
PrintBitmap prhdc
' The system will spend a long time in the EndPage
' function, but it will periodically call the Abort
' procedure which in turn triggers the Callback1
' AbortProc event.
di = EndPage(prhdc)
If di >= 0 Then di = EndDocAPI(prhdc)
Unload AbortForm
Enabled = True
cleanup2:
If prhdc <> 0 Then di = DeleteDC(prhdc)
If hPrinter <> 0 Then Call ClosePrinter(hPrinter)
End Sub
' This function retrieves the definition of the default
' printer on this system
'
Private Function GetDefPrinter$()
Dim def$
Dim di&
def$ = String$(128, 0)
di = GetProfileString("WINDOWS", "DEVICE", "", def$, 127)
def$ = agGetStringFromLPSTR$(def$)
GetDefPrinter$ = def$
End Function
' This function returns the driver module name
'
Private Function GetDeviceDriver$(dev$)
Dim firstpos%, nextpos%
firstpos% = InStr(dev$, ",")
nextpos% = InStr(firstpos% + 1, dev$, ",")
GetDeviceDriver$ = Mid$(dev$, firstpos% + 1, nextpos% - firstpos% - 1)
End Function
' Retrieves the name portion of a device string
'
Private Function GetDeviceName$(dev$)
Dim npos%
npos% = InStr(dev$, ",")
GetDeviceName$ = Left$(dev$, npos% - 1)
End Function
' Returns the output destination for the specified device
'
Private Function GetDeviceOutput$(dev$)
Dim firstpos%, nextpos%
firstpos% = InStr(dev$, ",")
nextpos% = InStr(firstpos% + 1, dev$, ",")
GetDeviceOutput$ = Mid$(dev$, nextpos% + 1)
End Function
' Prints the bitmap in the picture1 control to the
' printer context specified.
'
Private Sub PrintBitmap(hdc&)
Dim bi As BITMAPINFO
Dim dctemp&, dctemp2&
Dim msg$
Dim bufsize&
Dim bm As BITMAP
Dim ghnd&
Dim gptr&
Dim xpix&, ypix&
Dim doscale&
Dim uy&, ux&
Dim di&
' Create a temporary memory DC and select into it
' the background picture of the picture1 control.
dctemp& = CreateCompatibleDC(Picture1.hdc)
' Get the size of the picture bitmap
di = GetObjectAPI(Picture1.Picture, Len(bm), bm)
' Can this printer handle the DIB?
If (GetDeviceCaps(hdc, RASTERCAPS)) And RC_DIBTODEV = 0 Then
msg$ = "This device does not support DIB's" + vbCrLf + "See source code for further info"
MsgBox msg$, 0, "No DIB support"
End If
' Fill the BITMAPINFO for the desired DIB
bi.bmiHeader.biSize = Len(bi.bmiHeader)
bi.bmiHeader.biWidth = bm.bmWidth
bi.bmiHeader.biHeight = bm.bmHeight
bi.bmiHeader.biPlanes = 1
' Set to 24 here to create a 24 bit DIB
' Set to 8 here to create an 8 bit DIB
bi.bmiHeader.biBitCount = 4
bi.bmiHeader.biCompression = BI_RGB
' Now calculate the data buffer size needed
bufsize& = bi.bmiHeader.biWidth
' Figure out the number of bytes based on the
' number of pixels in each byte. In this case we
' really don't need all this code because this example
' always uses a 16 color DIB, but the code is shown
' here for your future reference
Select Case bi.bmiHeader.biBitCount
Case 1
bufsize& = Int((bufsize& + 7) / 8)
Case 4
bufsize& = Int((bufsize& + 1) / 2)
Case 24
bufsize& = bufsize& * 3
End Select
' And make sure it aligns on a long boundary
bufsize& = (Int((bufsize& + 3) / 4)) * 4
' And multiply by the # of scan lines
bufsize& = bufsize& * bi.bmiHeader.biHeight
' Now allocate a buffer to hold the data
' We use the global memory pool because this buffer
' could easily be above 64k bytes.
ghnd = GlobalAlloc(GMEM_MOVEABLE, bufsize&)
gptr& = GlobalLock&(ghnd)
di = GetDIBits(dctemp, Picture1.Picture, 0, bm.bmHeight, ByVal gptr&, bi, DIB_RGB_COLORS)
di = SetDIBitsToDevice(hdc, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, 0, bm.bmHeight, ByVal gptr&, bi, DIB_RGB_COLORS)
' Now see if we can also print a scaled version
xpix = GetDeviceCaps(hdc, HORZRES)
' We subtract off the size of the bitmap already
' printed, plus some extra space
ypix = GetDeviceCaps(hdc, VERTRES) - (bm.bmHeight + 50)
' Find out the largest multiplier we can use and still
' fit on the page
doscale = xpix / bm.bmWidth
If (ypix / bm.bmHeight < doscale) Then doscale = ypix / bm.bmHeight
If doscale > 1 Then
doscale = doscale
ux = bm.bmWidth * doscale
uy = bm.bmHeight * doscale
' Now how this is offset a bit so that we don't
' print over the 1:1 scaled bitmap
di = StretchDIBits(hdc, 0, bm.bmHeight + 50, ux, uy, 0, 0, bm.bmWidth, bm.bmHeight, ByVal gptr&, bi, DIB_RGB_COLORS, SRCCOPY)
End If
' Dump the global memory block
di = GlobalUnlock(ghnd)
di = GlobalFree(ghnd)
di = DeleteDC(dctemp)
End Sub
' Shows information about the current device mode
'
Private Sub ShowDevMode(dm As DEVMODE)
Dim crlf$
Dim a$
crlf$ = Chr$(13) + Chr$(10)
a$ = "Device name = " + agGetStringFromLPSTR$(dm.dmDeviceName) + crlf$
a$ = a$ + "Devmode Version: " + Hex$(dm.dmSpecVersion) + ", Driver version: " + Hex$(dm.dmDriverVersion) + crlf$
a$ = a$ + "Orientation: "
If dm.dmOrientation = DMORIENT_PORTRAIT Then a$ = a$ + "Portrait" Else a$ = a$ + "Landscape"
a$ = a$ + crlf$
a$ = a$ + "Field mask = " + Hex$(dm.dmFields) + crlf$
a$ = a$ + "Copies = " + Str$(dm.dmCopies) + crlf$
If dm.dmFields And DM_YRESOLUTION <> 0 Then
a$ = a$ + "X,Y resolution = " + Str$(dm.dmPrintQuality) + "," + Str$(dm.dmYResolution) + crlf$
End If
MsgBox a$, 0, "Devmode structure"
End Sub
Public Function OpenDefaultPrinter(Optional DeviceName) As Long
Dim dev$, devname$, devoutput$
Dim hPrinter&, res&
Dim pdefs As PRINTER_DEFAULTS
pdefs.pDatatype = vbNullString
pdefs.pDevMode = 0
pdefs.DesiredAccess = PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE
dev$ = GetDefPrinter$() ' Get default printer info
If dev$ = "" Then Exit Function
devname$ = GetDeviceName$(dev$)
devoutput$ = GetDeviceOutput$(dev$)
If Not IsMissing(DeviceName) Then
DeviceName = devname$
End If
' You can use OpenPrinterBynum to pass a zero as the
' third parameter, but you won't have full access to
' edit the printer properties
res& = OpenPrinter(devname$, hPrinter, pdefs)
If res <> 0 Then OpenDefaultPrinter = hPrinter
End Function
GSerg писал(а):Не буду даже пытаться разобраться в коде
GSerg писал(а):Скажи мне, а как должна отображаться на экране линия толщиной меньше одного пикселя, если минимальная единица отображения конечна и равна одному пикселю?
alibek писал(а):Он имеет ввиду совсем не это
Толковые графические редакторы применяют антиальясинг в процессе отображения масштабированного (уменьшенного) изображения. И очень тонкие линии получаются как бы пунктирными.
А он хочет нарисовать такую линию, которая бы выглядела тоньше, чем однопиксельная линия. И добиться этого можно только:
1) посчитав угол наклона линии и "плотность" пунктиров, рисовать вручную пунктиры.
2) возложить п.1 на API.
alibek писал(а):tyomitch, слово "пунктир" подразумевалось в кавычках. Я лучше проиллюстрирую.
сайт мне писал(а):Общая ошибка
Выбранное приложение больше не существует
404 File Not Found: The File files/ss_195.zip does not exist.
alibek писал(а):Ну тогда http://alibek09.narod.ru/ss.gif
Matew писал(а):VB ругается при попытки задать перо, тоньше 1((
tyomitch писал(а):Вот, типа, пример - "графический редактор"
Сейчас этот форум просматривают: AhrefsBot и гости: 40