Cvp: Accessde Vba Kodu İle Kapalı Excel Dosyasını Yazdırmak - feraz - 18/02/2020
ActivePrinter:="Microsoft XPS Document Writer"
Yukarıdaki tırnak içindeki yere yazıcı ismini yazarsanız default oluyormuş
Application.Dialogs(9).Show
Yukarıdaki kodlada yazıcı seçiyormuşsunuz.
Yani önce bu kodu altınada önceki kodu eklyip deneyebilirsiniz
Alttada konu işlenmiş tam inceleyemefim belki buda yardımcı olur.
Yazıcı seçme ve yazdırma
Cvp: Accessde Vba Kodu İle Kapalı Excel Dosyasını Yazdırmak - accessman - 18/02/2020
teşekkürler sn.feraz
Cvp: Accessde Vba Kodu İle Kapalı Excel Dosyasını Yazdırmak - feraz - 18/02/2020
Rica ederim,yapamazsanız bakarım akşama.
Cvp: Accessde Vba Kodu İle Kapalı Excel Dosyasını Yazdırmak - accessman - 18/02/2020
böyle bir modul var
Option Compare Database
Option Explicit
Private Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hWnd As Long, ByVal lpszOp As String, _
ByVal lpszFile As String, _
ByVal lpszParams As String, _
ByVal lpszDir As String, _
ByVal FsShowCmd As Long _
) As Long
Private Const SE_ERR_FNF = 2&
Private Const SE_ERR_PNF = 3&
Private Const SE_ERR_ACCESSDENIED = 5&
Private Const SE_ERR_OOM = 8&
Private Const SE_ERR_DLLNOTFOUND = 32&
Private Const SE_ERR_SHARE = 26&
Private Const SE_ERR_ASSOCINCOMPLETE = 27&
Private Const SE_ERR_DDETIMEOUT = 28&
Private Const SE_ERR_DDEFAIL = 29&
Private Const SE_ERR_DDEBUSY = 30&
Private Const SE_ERR_NOASSOC = 31&
Private Const SE_ERR_BAD_FORMAT = 11&
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const HWND_BROADCAST As Long = &HFFFF&
Private Const WM_WININICHANGE As Long = &H1A
' The following code allows one to read, and write to the WIN.INI files
' In win 2000 the printer settings are actually in the registry. However, windows
' handles this correctly
'
Private Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" _
(ByVal lpAppName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long
Private Declare Function WriteProfileString Lib "kernel32" _
Alias "WriteProfileStringA" _
(ByVal lpszSection As String, _
ByVal lpszKeyName As String, _
ByVal lpszString As String) As Long
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lparam As Any) As Long
Private Function fstrDField(mytext As String, delim As String, groupnum As Integer) As String
' this is a standard delimiter routine that every developer I know has.
' This routine has a million uses. This routine is great for splitting up
' data fields, or sending multiple parms to a openargs of a form
'
' Parms are
' mytext - a delimited string
' delim - our delimiter (usually a , or / or a space)
' groupnum - which of the delimited values to return
'
Dim startpos As Integer, endpos As Integer
Dim groupptr As Integer, chptr As Integer
chptr = 1
startpos = 0
For groupptr = 1 To groupnum - 1
chptr = InStr(chptr, mytext, delim)
If chptr = 0 Then
fstrDField = ""
Exit Function
Else
chptr = chptr + 1
End If
Next groupptr
startpos = chptr
endpos = InStr(startpos + 1, mytext, delim)
If endpos = 0 Then
endpos = Len(mytext) + 1
End If
fstrDField = Mid$(mytext, startpos, endpos - startpos)
End Function
Function SetDefaultPrinter(strPrinterName As String) As Boolean
Dim strDeviceLine As String
Dim strBuffer As String
Dim lngbuf As Long
' get the full device string
'
strBuffer = Space(1024)
lngbuf = GetProfileString("PrinterPorts", strPrinterName, "", strBuffer, Len(strBuffer))
'Write out this new printer information in
' WIN.INI file for DEVICE item
If lngbuf > 0 Then
strDeviceLine = strPrinterName & "," & _
fstrDField(strBuffer, Chr(0), 1) & "," & _
fstrDField(strBuffer, Chr(0), 2)
Call WriteProfileString("windows", "Device", strDeviceLine)
SetDefaultPrinter = True
' Below is optional, and should be done. It updates the existing windows
' so the "default" printer icon changes. If you don't do the below..then
' you will often see more than one printer as the default! The reason *not*
' to do the SendMessage is that many open applications will now sense the change
' in printer. I vote to leave it in..but your case you might not want this.
'
'Call SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, ByVal "windows")
Else
SetDefaultPrinter = False
End If
End Function
Function GetDefaultPrinter() As String
Dim strDefault As String
Dim lngbuf As Long
strDefault = String(255, Chr(0))
lngbuf = GetProfileString("Windows", "Device", "", strDefault, Len(strDefault))
If lngbuf > 0 Then
GetDefaultPrinter = fstrDField(strDefault, ",", 1)
Else
GetDefaultPrinter = ""
End If
End Function
Public Sub ListPrinters()
Debug.Print GetDefaultPrinter
Debug.Print "------------"
Debug.Print GetPrinters
End Sub
Function GetPrinters() As String
' this routine returns a list of printers, separated by
' a ";", and thus the results are suitable for stuffing into a combo box
Dim strBuffer As String
Dim strOnePtr As String
Dim intPos As Integer
Dim lngChars As Long
strBuffer = Space(2048)
lngChars = GetProfileString("PrinterPorts", vbNullString, "", strBuffer, Len(strBuffer))
If lngChars > 0 Then
intPos = InStr(strBuffer, Chr(0))
Do While intPos > 1
strOnePtr = Left(strBuffer, intPos - 1)
strBuffer = Mid(strBuffer, intPos + 1)
If GetPrinters <> "" Then GetPrinters = GetPrinters & vbCrLf
'Debug.Print strOnePtr
GetPrinters = GetPrinters & strOnePtr
intPos = InStr(strBuffer, Chr(0))
Loop
Else
GetPrinters = ""
End If
End Function
Public Sub PrinterSides(ByVal pyNum As Byte)
'acPRDPSimplex = 1
'acPRDPHorizontal = 2
'acPRDPVertical = 3
Select Case pyNum
Case ": 'nothing to do"
Case 1
rpt.Printer.Duplex = acPRDPSimplex
Case 2
rpt.Printer.Duplex = acPRDPHorizontal
Case 3
rpt.Printer.Duplex = acPRDPVertical
End Select
Printer.Duplex = pyNum
End Sub
Public Sub PrinterOrient()
'If CommonDialog1.Orientation = cdlLandscape Then
' Printer.Orientation = cdlLandscape '2
'Else
' Printer.Orientation = cdlPortrait '1
'End If
End Sub
Private Sub ProcessList(FileOp As String)
Dim varItem As Variant
Dim strFile As String
If Me.lstFiles.ItemsSelected.Count = 0 Then
MsgBox " No file selected for " & FileOp & "ing", vbExclamation, "Process"
Exit Sub
End If
For Each varItem In Me.lstFiles.ItemsSelected
strFile = Me.lstFiles.Column(1, varItem)
If ExecuteFile(strFile, FileOp) Then MsgBox "File " & FileOp & "ed"""
Debug.Print strFile
Next
End Sub
Public Sub PrintListOfFiles()
Dim sOld As String, sFilename As String
ExecuteFile sFilename, "print"
End Sub
Public Function ExecuteFile(DocName As String, Optional FileOp As String = "open") As Boolean
Dim lRetVal As Long, sMsg As String
lRetVal = ShellExecute(0&, FileOp, DocName, vbNullString, vbNullString, IIf(FileOp = "print", SW_HIDE, SW_SHOWNORMAL))
If lRetVal <= 32 Then
ExecuteFile = False
'There was an error
Select Case lRetVal
Case SE_ERR_FNF
sMsg = "File not found"
Case SE_ERR_PNF
sMsg = "Path not found"
Case SE_ERR_ACCESSDENIED
sMsg = "Access denied"
Case SE_ERR_OOM
sMsg = "Out of memory"
Case SE_ERR_DLLNOTFOUND
sMsg = "DLL not found"
Case SE_ERR_SHARE
sMsg = "A sharing violation occurred"
Case SE_ERR_ASSOCINCOMPLETE
sMsg = "Incomplete or invalid file association"
Case SE_ERR_DDETIMEOUT
sMsg = "DDE Time out"
Case SE_ERR_DDEFAIL
sMsg = "DDE transaction failed"
Case SE_ERR_DDEBUSY
sMsg = "DDE busy"
Case SE_ERR_NOASSOC
sMsg = "No association for file extension"
Case SE_ERR_BAD_FORMAT
sMsg = "Invalid EXE file or error in EXE image"
Case Else
sMsg = "Unknown error"
End Select
MsgBox "Cannot " & FileOp & " " & DocName & vbCrLf & vbCrLf & sMsg, vbExclamation
Else
ExecuteFile = True
End If
End Function
Cvp: Accessde Vba Kodu İle Kapalı Excel Dosyasını Yazdırmak - accessman - 18/02/2020
şöyle çağrılıyormuş
Sub btnPrintDocs()
Dim ptr1 As String
ptr1 = GetDefaultPrinter() 'save old printer
SetDefaultPrinter "CANON" 'set new printer
printExcel
'DoCmd.OpenReport "myReport" 'print my report
SetDefaultPrinter ptr1 'set back to old printer
End Sub
Cvp: Accessde Vba Kodu İle Kapalı Excel Dosyasını Yazdırmak - feraz - 18/02/2020
Verdiğiniz kodu kullanacaksanız Api olduğu için 64 bitte hata vermemesi için ptrsafe eklenmeli yoksa hata verir 64bit için.
Birde o kadar koda gerek varmı bilemedim.
Önceki verdiğim active printer yazan yer değiltirmiyormu yazıcı istediğiniz addaki.
|