Runtime error 75 path/file access error

Runtime error 75 path/file access error

Post by Del » Thu, 20 Feb 2003 23:48:08



After loading SQL SP3 I now have a user getting
a "path/file access error" on their WinNT wrkstation
whenever they run a word 2000 macro that accesses info
on our SQL 2k server.  Our developer has recently moved on
and unreachable so I am not sure where to start looking for
answers.  None of the technet articles had a solution
that seem to fit.  I have also noticed that it only
happens when the user is logged in and not me, my account
is a domain admin account.

Ok here's how I think the process goes:
1.) The user presses a hot key combo which calls an EXE
and passes a command parameter of /PICK
2.) The program opens and prints off a pick list then a
pack list
3.) Then word is suppose to open and print off a Datasheet
or MSDS if it is required. This is when the "Runtime error
75 path/file access error" pops up, before anything prints
off.  The user clicks ok then the program shuts down.

Somewhere in there a text file is written to and read from
that contains the MSDS and Datasheet the is suppose to
print.  The text file is O:\data\work\msdsp.txt.  This
worked fine until SQL SP3 was applied

I have peppered the program with MsgBox's and this is
where the runtime happens -
If Not rstMSDSFile.EOF Then
'write file name
'(MSDS File has a path
'AND msds needs printing)
'OR MSDS is checked
If rstMSDS![european] Then
'Write European MSDS path
Which is in the Public Sub Print_One() routine

Here is the VB Code:
Option Explicit

Public fMainForm As frmMain

Declare Function OpenProcess Lib "kernel32" (ByVal
dwDesiredAccess As Long, ByVal bInheritHandle As Long,
ByVal dwProcessId As Long) As Long
Declare Function WaitForSingleObject Lib "kernel32" (ByVal
hHandle As Long, ByVal dwMilliseconds As Long) As Long
Declare Function GetComputerName Lib "kernel32"
Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize
As Long) As Long
Declare Function GetUserName Lib "advapi32.dll"
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As
Long) As Long
Declare Function CloseHandle Lib "kernel32" (ByVal hObject
As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal
dwMilliseconds As Long)

Global dbcShipInst As ADODB.Connection
Global cnn As ADODB.Connection
Global rst As ADODB.Recordset
Public rsPick As Recordset

Sub Main()

    On Error GoTo EH
    Select Case Trim(LCase(Command))
        Case "/ack":
            DoEvents
            ACK
        Case "/pick":
            DoEvents
            PICK
        Case "/mp":
        'this is used for testing new code
            MP
        Case "":
        'open in edit mode
        'for the order dept.
            frmSplash.Show
            frmSplash.Refresh
            Set dbcShipInst = New ADODB.Connection
            dbcShipInst.Open
("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\orderdeptdb\shp2inst2k.mdb;Mode=ReadWrite;Persist
 Security Info=False")
            Set fMainForm = New frmMain
            Load fMainForm

            fMainForm.Show
            frmSplash.ZOrder (0)
    End Select
    Exit Sub

EH:
    Call UnexpectedError("Sub_Main", Err.Number,
Err.Description)
    Exit Sub

End Sub

Public Sub ACK()
    Dim x As Integer
    On Error GoTo EH
    'Print acknowledgments
    For x = 1 To HowMany
        frmAckPrint.Show
        frmAckPrint.Refresh
        rptAcknowledgement.PrintReport False
    Next x
    Unload frmAckPrint
    End
EH:
    Call UnexpectedError("ACK", Err.Number,
Err.Description)
    Exit Sub

End Sub

Public Sub PICK()
    On Error GoTo EH
    Set rsPick = New Recordset
    Set cnn = New Connection

    frmPrintSplash.Show
    frmPrintSplash.Refresh

    cnn.ConnectionString =
("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\orderdeptdb\shp2inst2k.mdb;Mode=Read;Persist
Security Info=False")
    cnn.Open

    'Open Pick ticket record set
    rsPick.CursorLocation = adUseClient
    rsPick.CursorType = adOpenStatic
    rsPick.LockType = adLockReadOnly
    rsPick.ActiveConnection = cnn
    rsPick.Source = "SELECT * from qryOrderPickReport2
order by CO_LN_NO"
    rsPick.Open
    If IsNull(rsPick!carrier) Then
        MsgBox "No carrier has been assigned to this
order. " & vbCrLf & "Please call the Order Dept. and have
them assign a carrier to this order.", vbOKOnly +
vbExclamation, "Carrier Not Assigned"
        Unload frmPrintSplash
        End
    End If
'   Print Pick ticket on Pink form
'   This is the "Color" tray code.
    rptPickList.Printer.PaperBin = 16648
    rptPickList.PrintReport False
    If rsPick!certws Then
        'Print Cert copy to white
        'This is the white tray code
        rptPickList.Printer.PaperBin = 16640
        rptPickList.PrintReport False
    End If

    Call Prt_Rptpack

    'print MSDS & Datasheets
    Print_One
    Unload frmPrintSplash
    End
EH:
    Call UnexpectedError("Pick", Err.Number,
Err.Description)
    Exit Sub

End Sub

Public Sub MP()
    'This is used for testing
    Exit Sub
EH:
    Call UnexpectedError("MP", Err.Number, Err.Description)
    Exit Sub

End Sub

Public Function HowMany() As Integer
    On Error GoTo EH
    'how many acknowledgements?
    HowMany = 1
    HowMany = Val(InputBox("How many Copies?"))
    If HowMany < 1 Then HowMany = 1
    Exit Function

EH:
    Call UnexpectedError("HowMany", Err.Number,
Err.Description)
    Exit Function

End Function

Public Function pickexttext()
    'Gets extended text for pick tickets, packing lists &
acknowledgements
    Dim dbf As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim Key As Long
    Dim Lastrec As Long
    Dim sVal As String
    Dim inCount As Integer
    Dim strQuery As String

    On Error GoTo EH
    sVal = ""
    inCount = 1

    Set dbf = New ADODB.Connection
    Set rst = New ADODB.Recordset
    'open recordset to get text
    dbf.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\Orderdeptdb\shp2inst2k.mdb")
    strQuery = "SELECT DISTINCTROW PICKEXT.CO_NUMBER,
PICKEXT.PAGE_NO, PICKEXT.SEQN_NO, PICKEXT.COHDR_XTXT AS
[Text] " & _
                    "From PICKEXT " & _
                "Where ((Not (PICKEXT.COHDR_XTXT) Is
Null)) " & _
                "ORDER BY PICKEXT.PAGE_NO,
PICKEXT.SEQN_NO;"
    rst.Open strQuery, dbf
    Lastrec = 0
    'count the number of text lines
    Do While Not rst.EOF
        Lastrec = Lastrec + 1
        rst.MoveNext
    Loop
    'if none, then exit function
    If Lastrec < 1 Then
        pickexttext = ""
        Exit Function
    End If

    'return text
    rst.MoveFirst
    While inCount <= Lastrec
        sVal = sVal + Chr(13) + Chr(10) + rst!Text
        inCount = inCount + 1
        rst.MoveNext
    Wend

    pickexttext = sVal
    rst.Close
    Exit Function

EH:
    Call UnexpectedError("Pickexttext", Err.Number,
Err.Description)
    Exit Function

End Function

Public Sub Print_One()
    Dim dbf As ADODB.Connection
    Dim comControl As Command
    Dim comMSDS As Command
    Dim comMSDSFile As Command
    Dim rstControl As ADODB.Recordset
    Dim rstMSDS As ADODB.Recordset
    Dim rstMSDSFile As ADODB.Recordset
    Dim ControlStr As String, MSDSStr As String,
MSDSFileStr As String
    Dim i As Integer, recCount As Integer
    Dim j As Integer, MSDSCount As Integer
    Dim retval As Long, rPointer, tSpec
    Dim tMSDS As String
    Dim lIsWindow As Long
    Dim SearchStr As String
    Dim SearchDAT As String
    Dim strword As String
    Dim oOutlook As Outlook.Application
    Dim fso As FileSystemObject
    Dim fsFolder As Folder, fsTempFolder As Folder
    Dim filQueue As TextStream
    Dim filKey As TextStream

    On Error GoTo EH
    'initialize variables
    ControlStr = "SELECT DISTINCTROW CO_NUMBER, DS, MSDS,
Cust_ID, Ship_to_ID FROM qryOrderPickReport ;"
    MSDSFileStr = "SELECT [item No], MSDSName from
toxtable"

    Set dbf = New ADODB.Connection
    Set comControl = New Command
    Set comMSDS = New Command
    Set comMSDSFile = New Command
    Set rstControl = New ADODB.Recordset
    Set rstMSDSFile = New ADODB.Recordset
    Set rstMSDS = New ADODB.Recordset

    'open DB
    dbf.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\orderdeptdb\shp2inst2k.mdb")

    comControl.ActiveConnection = dbf
    comControl.CommandText = ControlStr
    Set rstControl = comControl.Execute

    comMSDSFile.ActiveConnection = dbf
    comMSDSFile.CommandText = "Select * from toxtable
order by [item no]"
    rstMSDSFile.CursorType = adOpenDynamic
    rstMSDSFile.Source = "Select * from toxtable order by
[item no]"
    rstMSDSFile.ActiveConnection = dbf
    rstMSDSFile.Open
    rstControl.MoveFirst

    ' Find material to send MSDS for
    MSDSStr = "SELECT * FROM pickdet as p1 inner join
(pickhead as p2 inner join tblinstuctions as t1 on t1.vcid
= p2.cust_id and t1.ship_to_id = p2.SHIP_TO_ID) on
p2.co_number = p1.co_number WHERE (LN_STA) = '4' ;"
    comMSDS.ActiveConnection = dbf
    comMSDS.CommandText = MSDSStr
    Set rstMSDS = comMSDS.Execute
    rstMSDS.MoveFirst
    MSDSCount = 0
    Do Until rstMSDS.EOF
        MSDSCount = MSDSCount + 1
        rstMSDS.MoveNext
    Loop
    rstMSDS.MoveFirst
    'set up log files
    Set fso = New FileSystemObject
    Set fsFolder = fso.GetFolder("O:\data\")
    Set fsTempFolder = fso.GetSpecialFolder
(TemporaryFolder)

    Set filKey = fso.OpenTextFile(fsFolder.Path
& "\msdskeys.txt", ForAppending)
    Set filQueue = fso.OpenTextFile(fsTempFolder.Path
& "\msdsp.txt", ForWriting, True)
    filKey.WriteLine "-------------------------------------
----"

    SearchStr = "|"
    SearchDAT = "|"
    For j = 1 To MSDSCount
        'CHECK TO SEE IF IT'S A COMPANY THAT DOES NOT WANT
MSDS OR DATA SHEET
        If Trim(rstMSDS![p1.Cust_ID]) = "FO102" Or Trim
(rstMSDS![p1.Cust_ID] = "ME600") Then
        'Company doesn't want MSDS/DS
        Else
            rPointer = InStr(rstMSDS![Item], " ")
            If rPointer > 0 Then
                tMSDS = Mid(rstMSDS![Item], 1, rPointer -
1)
            Else
                tMSDS = rstMSDS![Item]
            End If
            tSpec = IIf(Right(tMSDS, 1) >= "A" And Right
(tMSDS, 1) <= "Z", Mid(tMSDS, 1, Len(tMSDS) - 1), tMSDS)
            rstMSDSFile.MoveFirst
            rstMSDSFile.Find "[item no] = '" & tMSDS
& "'", , adSearchForward
            If Not rstMSDSFile.EOF Then
                'write file name
                '(MSDS File has a path
                'AND msds needs printing)
                'OR MSDS is checked
                If rstMSDS![european] Then
                'Write European MSDS path
                    If IsNull(rstMSDSFile!MSDSPathEuro) Or
Trim(rstMSDSFile!MSDSPathEuro) = "" Then
                        SendMessage tMSDS, rstMSDS!european
                    End If
                    If (Not IsNull(rstMSDSFile!
MSDSPathEuro) _
                           And (Not _
                           IsMSDSOK(rstControl!Cust_ID, _
                           rstControl!ship_to_id, _
                           rstMSDSFile![item no],
rstMSDSFile!MSDSPathEuro))) Or Not IsNull(rstMSDSFile!
MSDSPathEuro) And rstControl!msds Then
                            If InStr(SearchStr, "|" +
tMSDS + "|") = 0 Then
                                SearchStr = SearchStr +
tMSDS + "|"
                                filQueue.WriteLine
rstMSDSFile!MSDSPathEuro
                                filKey.WriteLine
rstMSDSFile!MSDSPathEuro
                            End If
                     End If
                Else
                'Continue as normal
                    If IsNull(rstMSDSFile!MSDSPath) Or Trim
(rstMSDSFile!MSDSPath) = "" Then
                        SendMessage tMSDS, rstMSDS!european
                    End If
                    If (Not IsNull(rstMSDSFile!MSDSPath) _
                           And (Not _
                           IsMSDSOK(rstControl!Cust_ID, _
                           rstControl!ship_to_id, _
                           rstMSDSFile![item no],
rstMSDSFile!MSDSPath))) Or Not IsNull(rstMSDSFile!
MSDSPath) And rstControl!msds Then

                        If InStr(SearchStr, "|" + tMSDS
+ "|") = 0 Then
                            SearchStr = SearchStr + tMSDS
+ "|"
                            filQueue.WriteLine rstMSDSFile!
MSDSPath
                            filKey.WriteLine rstMSDSFile!
MSDSPath
                        End If
                    End If
                End If
                If Not IsNull(rstMSDSFile!SPECPath) And
rstControl!ds Then
                    If InStr(SearchDAT, "|" + tSpec + "|")
= 0 Then
                        SearchDAT = SearchDAT + tSpec + "|"
                        filQueue.WriteLine rstMSDSFile!
SPECPath
                        filKey.WriteLine rstMSDSFile!
SPECPath
                    End If
                End If
            End If
        End If

        rstMSDS.MoveNext
    Next j      'Next Line Item
    filQueue.Close
    'log printing MSDS
    filKey.WriteLine Now()
    filKey.WriteLine rstControl!Cust_ID
    filKey.WriteLine rstControl!ship_to_id
    filKey.WriteLine rstControl!CO_Number
    filKey.WriteLine SearchStr
    filKey.WriteLine SearchDAT
    filKey.WriteLine GetUserNameT()
    filKey.WriteLine GetComputerNameT()
    filKey.Close
    Sleep (3000)

    ' print MSDSs for this order
    PrintDoc

    rstControl.Close
    rstMSDS.Close
    rstMSDSFile.Close

    Set rstControl = Nothing
    Set rstMSDS = Nothing
    Set rstMSDSFile = Nothing
    Set comControl = Nothing
    Set comMSDS = Nothing
    Set comMSDSFile = Nothing
    dbf.Close
    Set dbf = Nothing

    Close

    Exit Sub

EH:
    Call UnexpectedError("Print_One", Err.Number,
Err.Description)
    Exit Sub
End Sub

Public Function GetUserNameT()
    Dim s$, CNT&, dl&
    On Error GoTo EH
    CNT& = 199
    s$ = String$(200, 0)
    dl& = GetUserName(s$, CNT)
    GetUserNameT = Left$(s$, CNT - 1)
    Exit Function

EH:
    Call UnexpectedError("GetUserNameT", Err.Number,
Err.Description)
    Exit Function
End Function

Public Function GetComputerNameT()
    Dim s$, dl&
    On Error GoTo EH
    s = String$(20, 0)
    dl& = GetComputerName(s$, 20)
    GetComputerNameT = Trim(s$)
    Exit Function
EH:
    Call UnexpectedError("GetComputerNameT", Err.Number,
Err.Description)
    Exit Function

End Function

Public Function IsMSDSOK(ByVal strCust, ByVal strShipto,
ByVal strItem, ByVal strMSDS) As Boolean
    Dim strSQL As String
    Dim rst As ADODB.Recordset
    Dim dbf As ADODB.Connection
    Dim recs

    On Error GoTo EH
    'Dont' send MSDS on domestic samples
    If strCust = "SAMPLE" Then
        IsMSDSOK = False
        Exit Function
    End If

    Set dbf = New ADODB.Connection
    Set rst = New ADODB.Recordset

    'Find MSDS
    dbf.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\orderdeptDB\shp2inst2k.mdb")
    strSQL = "select * from tblMSDSSent where custId = '"
& strCust & "' and shiptoid = '" & strShipto & "' and
itembase = '" & strItem & "'"
    rst.Open strSQL, dbf, adOpenDynamic, adLockOptimistic
    recs = 0
    Do While Not rst.EOF
        recs = recs + 1
        rst.MoveNext
    Loop
    If recs = 0 Then
        rst.AddNew
        rst!custid = strCust
        rst!ShipToID = strShipto
        rst!itembase = strItem
        rst!msdsname = strMSDS
        rst!senddate = Now()
        rst.Update
        IsMSDSOK = False
        rst.Close
        dbf.Close
        Exit Function
    End If
    rst.MoveFirst
    If rst!msdsname = strMSDS And (Val(Format(rst!
senddate, "YYYY")) = Year(Now())) Then
        IsMSDSOK = True
        rst.Close
        dbf.Close
        Exit Function
    Else
        rst!msdsname = strMSDS
        rst!senddate = Now()
        rst.Update
    End If
    IsMSDSOK = False
    rst.Close
    dbf.Close
    Exit Function

EH:
    Call UnexpectedError("IsMSDSOK", Err.Number,
Err.Description)
    Exit Function

End Function

Private Sub WaitforTerm(pid&)
    Dim phnd&
    On Error GoTo EH
    phnd = OpenProcess(&H100000, 0, pid)
    If phnd <> 0 Then
        Call WaitForSingleObject(phnd, &HFFFF)
        Call CloseHandle(phnd)
    End If

    Exit Sub

EH:
    Call UnexpectedError("WaitforTerm", Err.Number,
Err.Description)
    Exit Sub

End Sub

Public Sub PrintDoc()
    Dim objWord As Word.Application
    Dim WordDoc As New Word.Document
    Dim CurDoc As String
    Dim DefaultPrtr As String
    Dim x As Printer
    Dim adAcrobat As Object
    Dim objXL As Excel.Application
    Dim xlDoc As Excel.Workbook
    Dim fso As FileSystemObject
    Dim filPrintQueue As TextStream
    Dim fsFolder As Folder
    Dim r As Integer
    Dim str As String

    On Error GoTo EH

    'Open file to print docs
    Set fso = New FileSystemObject
    str = fso.GetTempName
    Set fsFolder = fso.GetSpecialFolder(TemporaryFolder)
    Set filPrintQueue = fso.OpenTextFile(fsFolder.Path
& "\msdsp.txt", ForReading, False)

    Do While Not filPrintQueue.AtEndOfStream
        CurDoc = filPrintQueue.ReadLine

        If fso.FileExists(CurDoc) Then
            'Print Word Doc
            If InStr(1, LCase(CurDoc), ".doc") > 0 Or InStr
(1, LCase(CurDoc), ".htm") > 0 Then
                If objWord Is Nothing Then
                    Set objWord = CreateObject
("Word.Application")
                Else
                    Set objWord = GetObject
(, "Word.Application")
                End If

                Set WordDoc = objWord.Documents.Open
(CurDoc)

WordDoc.Application.Options.PrintProperties = False
                WordDoc.PrintOut (False)
                While
objWord.Application.BackgroundPrintingStatus > 0
                    DoEvents
                Wend
                WordDoc.Close
            'Print PDF
            ElseIf InStr(1, LCase(CurDoc), ".pdf") Then
                Set adAcrobat = CreateObject
("APSpool.Object")
                r = adAcrobat.pdfspool(CurDoc, "")
                Set adAcrobat = Nothing
            'Print Excel
            ElseIf InStr(1, LCase(CurDoc), ".xls") Or InStr
(1, LCase(CurDoc), ".wk4") Then
                If objXL Is Nothing Then
                    Set objXL = CreateObject
("excel.Application")
                Else
                    Set objXL = GetObject
(, "excel.Application")
                End If

                Set xlDoc = objXL.Workbooks.Open(CurDoc)
                xlDoc.Application.ActiveWorkbook.PrintOut
                xlDoc.Application.ActiveWorkbook.Close
            End If
        Else
            'send message to H&S that file does not exist
            SendMessage2 (CurDoc)
        End If
    Loop
    filPrintQueue.Close

    'destroy vars
    If Not (WordDoc Is Nothing) Then Set WordDoc = Nothing
    If Not (objWord Is Nothing) Then
objWord.Application.Quit
    If Not (objWord Is Nothing) Then Set objWord = Nothing
    If Not (xlDoc Is Nothing) Then Set xlDoc = Nothing
    If Not (objXL Is Nothing) Then objXL.Application.Quit
    If Not (objXL Is Nothing) Then Set objXL = Nothing

    Exit Sub

EH:
    If Err.Number = 5174 Then
        MsgBox "No MSDS was found at the location: " &
CurDoc & vbCrLf & "Please contact the Health and Saftey
Dept. so this information may be corrected.", vbOKOnly +
vbExclamation, "MSDS Not Found"
        Exit Sub
    Else
        MsgBox Err.Number & " " & Err.Description
    End If
    Exit Sub

End Sub

Function Prt_Rptpack()
    Dim mydb As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim prtnum As Integer

    On Error GoTo EH
    Set mydb = New ADODB.Connection
    Set rs = New ADODB.Recordset
    mydb.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\orderdeptDB\shp2inst2k.mdb;Mode=ReadWrite;Persist
 Security Info=False")

    rs.Open "SELECT tblInstuctions.International " & _
"FROM PICKHEAD INNER JOIN tblInstuctions ON trim
(PICKHEAD.CUST_ID) = tblinstuctions.VCID and trim
(PICKHEAD.ship_to_id) = tblInstuctions.ship_to_id;", mydb,
adOpenStatic, adLockReadOnly
    'print twice if Commercial Invoice
    'Print once if Packlist

    If rs![International] = True Then

        prtnum = 2

    Else

        prtnum = 1

    End If

    '    Print Packing List on white form
    rptPackList.Printer.PaperBin = 7

    Do
        rptPackList.PrintReport False
        prtnum = prtnum - 1
    Loop Until prtnum = 0

    rs.Close
    mydb.Close
    Set mydb = Nothing
    Set rs = Nothing
    Exit Function

EH:
    Call UnexpectedError("Prt_Rptpack", Err.Number,
Err.Description)
    Exit Function

End Function

Public Function ackheaderext()
    'Print Acknowledgement header info
    Dim dbf As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim Key As Long
    Dim Lastrec As Long
    Dim sVal As String
    Dim inCount As Integer
    Dim strQuery As String

    On Error GoTo EH
    sVal = ""
    inCount = 1

    Set dbf = New ADODB.Connection
    Set rst = New ADODB.Recordset

    dbf.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=M:\Orderdeptdb\shp2inst2k.mdb")
    strQuery = "SELECT DISTINCTROW ackEXT.CO_NUMBER,
ackEXT.PAGE_NO, ackEXT.SEQN_NO, ackEXT.COHDR_XTXT AS
[Text] " & _
                    "From ackEXT " & _
                "Where ((Not (ackEXT.COHDR_XTXT) Is
Null)) " & _
                "ORDER BY ackEXT.PAGE_NO, ackEXT.SEQN_NO;"
    rst.Open strQuery, dbf
    Lastrec = 0
    Do While Not rst.EOF
        Lastrec = Lastrec + 1
        rst.MoveNext
    Loop
    If Lastrec < 1 Then
        ackheaderext = ""
        Exit Function
    End If
    rst.MoveFirst
    While inCount <= Lastrec
        sVal = sVal + Chr(13) + Chr(10) + rst!Text
        inCount = inCount + 1
        rst.MoveNext
    Wend

    ackheaderext = sVal
    rst.Close

    Exit Function

EH:
    Call UnexpectedError("ackheaderext", Err.Number,
Err.Description)
    Exit Function

End Function

Public Sub UnexpectedError(pstrSub, pstrErrNum,
pstrErrDesc)
    Dim strUN As String
    Dim strPC As String
    'error logging
    strUN = GetUserNameT
    strPC = GetComputerNameT
    Open "M:\orderdeptdb\ErrLog\Error.log" For Append As #1

    Print #1, Date & "|" & Time & "|" & Trim(strUN) & "|"
& Trim(strPC) & "|" & pstrSub & "|" & pstrErrNum & "|" &
pstrErrDesc

    Close 1

    MsgBox "Error: " & pstrErrNum & Chr(13) & _
            "Description : " & pstrErrDesc & Chr(13) & _
            "Please contact the IS Department for
assistance.", vbOKOnly + vbExclamation, "Unexpected Error"

End Sub

Function SendMessage(Material As String, Euro As Boolean)
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim ynError As Boolean

    ynError = False
    Set objOutlook = New Outlook.Application
    On Error Resume Next
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    If Err.Number = -2113732605 Then
        ynError = True
        Set objOutlook = StartApp("Outlook.Application")
        Set objOutlookMsg = objOutlook.CreateItem
(olMailItem)
    End If
    On Error GoTo 0

    With objOutlookMsg
       Set objOutlookRecip = .Recipients.Add("DL-Thermoset
Health & Safety")
        .Subject = "MSDS Error"
        If Euro Then
            .Body = "There was a problem locating an
European MSDS for: " & Material
        Else
            .Body = "There was a problem locating a MSDS
for: " & Material
        End If
        .Importance = olImportanceNormal

        For Each objOutlookRecip In .Recipients

            objOutlookRecip.Resolve

        Next
        .Send
        'notify Shipping that email was sent
        MsgBox "MSDS not found for " & Material & "." &
vbCrLf & "An email message has automatically been sent to
the Health & Safety Dept.", vbOKOnly +
vbInformation, "MSDS Not Found"

        End With

    If ynError Then
        objOutlook.Quit
    End If

    Set objOutlook = Nothing

End Function

Public Function StartApp(pstrProgID As String) As Object

    Dim objOTmp As Object

    Dim strStAppName As String

    On Error Resume Next

    Set objOTmp = GetObject(, pstrProgID)

    If Err.Number <> 0 Then

        Set objOTmp = CreateObject(pstrProgID)

        strStAppName = "C:\Program Files\Microsoft
Office\Office\OUTLOOK.EXE"
        Call Shell(strStAppName, 1)

    End If

    Set StartApp = objOTmp

    StartApp.Visible = True

End Function

Function SendMessage2(CurDoc As String)
    Dim objOutlook As Outlook.Application
    Dim objOutlookMsg As Outlook.MailItem
    Dim objOutlookRecip As Outlook.Recipient
    Dim objOutlookAttach As Outlook.Attachment
    Dim ynError As Boolean

    ynError = False
    Set objOutlook = New Outlook.Application
    On Error Resume Next
    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
    If Err.Number = -2113732605 Then
        ynError = True
        Set objOutlook = StartApp("Outlook.Application")
        Set objOutlookMsg = objOutlook.CreateItem
(olMailItem)
    End If
    On Error GoTo 0

    With objOutlookMsg
       Set objOutlookRecip = .Recipients.Add("DL-Thermoset
Health & Safety")
        .Subject = "File Error"
        .Body = "There was a problem printing the
following file: " & CurDoc & vbCrLf & _
            "Reason: File not Found"
        .Importance = olImportanceNormal

        For Each objOutlookRecip In .Recipients

            objOutlookRecip.Resolve

        Next
        .Send
        'notify Shipping that email was sent
        MsgBox "There was an error printing " & CurDoc
& "." & vbCrLf & "An email message has automatically been
sent to the Health & Safety Dept.", vbOKOnly +
vbInformation, "MSDS Not Found"

        End With

    If ynError Then
        objOutlook.Quit
    End If

    Set objOutlook = Nothing

End Function

Public Function IsHazardous(strMaterial As String)
    Dim intLen As Integer
    Dim intLength As Integer
    Dim strSQL As String
    Dim rs As ADODB.Recordset

    intLength = Len(Trim(strMaterial))
    intLen = InStr(1, Trim(strMaterial), " ") - 1
    If intLen <> -1 Then
        intLen = intLength - intLen
        strMaterial = Left(Trim(strMaterial), Len(Trim
(strMaterial)) - intLen)
    End If

    strSQL = "SELECT Toxtable.[Item No] " & _
                "FROM Toxtable INNER JOIN
tblHazardousShippingCodes ON Toxtable.[Shipping Code] =
tblHazardousShippingCodes.ShippingCode " & _
                "Where [Item No] = '" & strMaterial & "'"

    Set rs = New Recordset

    rs.ActiveConnection = cnn
    rs.CursorLocation = adUseServer
    rs.CursorType = adOpenStatic
    rs.LockType = adLockReadOnly
    rs.Source = strSQL
    rs.Open

    If rs.BOF Or rs.EOF Then
        IsHazardous = False
    Else
        IsHazardous = True
    End If
    rs.Close
    Set rs = Nothing
End Function

Here is the code that I found in two different word
macros:

Public Sub MAIN()
WordBasic.FormatFont Points:="12", Underline:=0, Color:=0,
StrikeThrough:=0, Superscript:=0, Subscript:=0, Hidden:=0,
SmallCaps:=0, AllCaps:=0, Spacing:="0 pt", Position:="0
pt", Kerning:=0, KerningMin:="", Tab:="0", Font:="Courier
New", Bold:=0, Italic:=0, Outline:=0, Shadow:=0
End Sub

Public Sub MAIN()
Dim CURDOC$
Open "O:\DATA\WORK\MSDSP.TXT" For Input As 1
While Not EOF(1)
    Line Input #1, CURDOC$
    WordBasic.FileOpen Name:=CURDOC$, ReadOnly:=1
    WordBasic.FilePrint Background:=0
    WordBasic.FileClose 2
Wend
Close 1
' FilePrint .Background = 0
WordBasic.FileExit 2

End Sub

 
 
 

1. Error 75: File/Path Access Error

I'm developing an application in VB 5.0 that is using a database.  I
created an installation package using the VB Setup Wizard, and did an
installation on NT Server 4.0 (no service packs installed).  It runs
fine.

Another person has installed it on NT Server 4.0 (SP2) and keeps
getting "Error 75: File/Path Access Error"  Any ideas on what could be
causing this?

The statement reads:
myDB = DBEngine.OpenDatabase(App.Path & "\" & "myDB.mdb")

I have also tried:
myDB = DBEngine.OpenDatabase(App.Path + "\" + "myDB.mdb")
myDB = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\" &
"myDB.mdb")

The file myDB.mdb DOES exist, as it was installed with the
application.

I have had the person try installing it as Administrator vs. User, in
a directory other than the default "C:\Program Files\myApp" directory.

The error occurs if he runs the application as Admin or as User.

I have checked to ensure the file is not read-only (if it is, a
different error occurs).

Thanks for any assistance!

2. URGENT HELP (internal error failgetposition1)

3. Btrieve Error 75

4. need help w/list fields FPW2.6

5. Error code 75?

6. Java Stored Procedures...any thoughts?

7. path/file access error

8. SQL 7, Window 2000, Connection problem

9. Path/File Access Error

10. path/file access error during setup

11. Path/File access error

12. Wyse60 as ANSI in Oracle, Wyse60/75 CRT file