by 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