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