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
