Why am I getting run-time error '3256' when Excel workbook is shar

S

slcards

I am connecting to a SQL server in my VBA code and performing a query. It
works fine when the workbook is not shared, but when I share the workbook it
stops working and I get the error message "Run-time error '3256'"? Here is
my code

' Maternal Serum Screening Load Accession Macro
' Written by Stuart Timm
' Version 1.0 Dated 07/30/08

Const MS_ONLY As String = "MS ONLY"
Const AFP_MS As String = "AFP MS"
Const AFP_MS3 As String = "AFP MS3"
Const AFP_MS4 As String = "AFP MS4"
Const MS_FT As String = "MS FT"
Const MS_SEQ1 As String = "MS SEQ-1"
Const MS_INT1 As String = "MS INT-1"


Private Function CreateConnection() As ADODB.connection
On Error GoTo He11

Dim connection As ADODB.connection

Set connection = New ADODB.connection

' connection.ConnectionString = "Provider=MSDASQL;Driver=(SQL
Server);Data Source=ANSR_DEV;" & _
'
"ParentCatalog=dbANSR_DEV;UID=mats;PWD=jh%jCCH9;TrustedConnection=Yes"
' connection.ConnectionString = "Provider=MSDASQL;Driver=(SQL
Server);Data Source=ANSR_CERT;" & _
'
"ParentCatalog=dbANSR_CERT;UID=mats;PWD=jh%jCCH9;TrustedConnection=Yes"
connection.ConnectionString = "Provider=MSDASQL;Driver=(SQL Server);Data
Source=ANSR_PROD;" & _

"ParentCatalog=dbANSR_PROD;UID=mats;PWD=jh%jCCH9;TrustedConnection=Yes"
connection.Open

Set CreateConnection = connection

Exit Function

He11:
MsgBox (connection.Errors.Item(0).Description)
End Function

Private Function CreateCommand(sql As String, cn As ADODB.connection) As
ADODB.Command
Dim myCommand As ADODB.Command
Set myCommand = New ADODB.Command
Set myCommand.ActiveConnection = cn
myCommand.CommandText = sql
myCommand.CommandTimeout = 30
Set CreateCommand = myCommand
End Function

Private Function CreateRecordset(cmd As ADODB.Command) As ADODB.Recordset
Dim myRecordset As ADODB.Recordset
Dim param As ADODB.Parameter

Set myRecordset = New ADODB.Recordset
Set myRecordset.Source = cmd

myRecordset.CursorLocation = adUseClient ' All data gets loaded to the
client computer before anything happens
myRecordset.CursorType = adOpenStatic ' Data is read both ways, but
cannot be updated
myRecordset.LockType = adLockReadOnly ' Read only

Set CreateRecordset = myRecordset
End Function

Public Sub LoadAccession()
On Error GoTo He11

Dim myConnection As ADODB.connection
Dim myCmd As ADODB.Command
Dim myRS As ADODB.Recordset
Dim iRow As Integer
Dim orderedTest As String
Dim resultTest As String
Dim result As String
Dim accession As String
Dim dateOfBirth As String

If (IsEmpty(ActiveWorkbook.Worksheets("Main").Range("B5"))) Then
MsgBox "No accession entered. Please enter a valid accession.",
vbCritical + vbOKOnly, "Missing Accession"
Else
Set myConnection = CreateConnection()
Set myCmd = CreateCommand("select r.Order_Test_Num, r.Accession,
p.Patient_Name, " & _
"p.Birth_When, r.Result_Test_Num,
r.Result, o.Collection_When, " & _
"t.Test_Mnemonic " & _
"from tblPatient p (nolock), tblTestResult
r (nolock), " & _
"tblTestOrder o (nolock), tblTestDirectory
t (nolock) " & _
"where r.Accession = '" &
ActiveWorkbook.Worksheets("Main").Range("B5") & "' " & _
"and r.Encounter = p.Encounter " & _
"and r.Accession = o.Accession " & _
"and r.Encounter = o.Encounter " & _
"and r.Order_Test_Num = o.Test_Num " & _
"and r.Order_Test_Num = t.Test_Num " & _
"and r.Result_Test_Num not in
('0080939','0080242','0081084','0080484'," & _

"'0081212','0081211','0081210','0081334','0081330','0080243','0080239'," & _

"'0080263','0081085','0081061','0081060','0081083','0081082','0081086'," & _

"'0081338','0080241','0080266','0080267','0080918','0080920','0080922'," & _

"'0080928','0080932','0080936','0080937','0080942','0080943','0081164') " & _
"order by r.Result_Test_Num", myConnection)

Set myRS = CreateRecordset(myCmd)

' Open the database
myRS.Open
Debug.Print "Number of records found = " & myRS.RecordCount
If (myRS.RecordCount = 0) Then
MsgBox "No records found for accession '" &
ActiveWorkbook.Worksheets("Main").Range("B5") & "'.", _
vbCritical + vbOKOnly, "No Records Found"
Exit Sub
End If

Worksheets("Input").Activate

ActiveWorkbook.Worksheets("Input").Range("B5").Value = myRS(1) '
Accession
ActiveWorkbook.Worksheets("Input").Range("B4").Value = myRS(2) '
Patient Name
ActiveWorkbook.Worksheets("Input").Range("B7").Value =
Format(myRS(6), "yyyymmdd") ' Collection Date
ActiveWorkbook.Worksheets("Input").Range("B8").Value = myRS(7) '
Ordered Test Mnemonic
dateOfBirth = Format(myRS(3), "mm/dd/yyyy")
ActiveWorkbook.Worksheets("Input").Range("B9").Value = dateOfBirth
' Date of Birth

' Start with the Main worksheet. Some fields have to be filled in
here.
Worksheets("Main").Activate
ActiveSheet.Unprotect Password:="wkea"

ActiveWorkbook.Worksheets("Main").Range("B5").Value = myRS(1)
ActiveWorkbook.Worksheets("Main").Range("B6").Value = myRS(2)
' Test type must be set in the Main sheet because that's where
the test names are maintained.
ActiveWorkbook.Worksheets("Main").Range("B7").Value = _
ActiveWorkbook.Worksheets("Input").Range("E8").Value



orderedTest = myRS(7) ' Ordered Test Mnemonic

If (orderedTest = MS_ONLY) Or (orderedTest = AFP_MS) Or (orderedTest
= AFP_MS3) _
Or (orderedTest = AFP_MS4) Then
' Start with the Main worksheet. Some fields have to be filled
in here.
' Switch to the Main worksheet
Worksheets("Main").Activate
ActiveSheet.Unprotect Password:="wkea"

' Date of Birth
ActiveWorkbook.Worksheets("Main").Range("B8").Value = dateOfBirth
' Collection Date
ActiveWorkbook.Worksheets("Main").Range("B9").Value = _
ActiveWorkbook.Worksheets("Input").Range("E7").Value

' The following fields come from the individual test results
based upon the result test number.
iRow = 1
Do Until myRS.EOF
resultTest = myRS(4) ' Result Test Number
result = myRS(5) ' Result

If (resultTest = "0080917") Then ' Maternal Weight
ActiveWorkbook.Worksheets("Main").Range("B14").Value =
result
ElseIf (resultTest = "0080926") Then ' Race
ActiveWorkbook.Worksheets("Main").Range("B18").Value =
String(1, result)
ElseIf (resultTest = "0080021") Then ' AFP
ActiveWorkbook.Worksheets("Main").Range("B10").Value =
result
ElseIf (resultTest = "0080935") Then ' hCG
ActiveWorkbook.Worksheets("Main").Range("B11").Value =
result
ElseIf (resultTest = "0080941") Then ' uE3
ActiveWorkbook.Worksheets("Main").Range("B12").Value =
result
ElseIf (resultTest = "0080927") Then ' Fetal Number
If ((String(1, result) = "U") Or (String(1, result) =
"0") Or (String(1, result) = "N")) Then
ActiveWorkbook.Worksheets("FT
Main").Range("B17").Value = "U"
ElseIf ((String(1, result) = "O") Or (String(1, result)
= "S")) Then
ActiveWorkbook.Worksheets("FT
Main").Range("B17").Value = "1"
ElseIf ((result = "TWO") Or (result = "TWINS")) Then
ActiveWorkbook.Worksheets("FT
Main").Range("B17").Value = "2"
ElseIf (result = "TRIPLETS") Then
ActiveWorkbook.Worksheets("FT
Main").Range("B17").Value = "3"
Else
ActiveWorkbook.Worksheets("FT
Main").Range("B17").Value = "U"
End If
ElseIf (resultTest = "0080938") Then ' Gest Age
ActiveWorkbook.Worksheets("Main").Range("B15").Value =
result
ElseIf (resultTest = "0080923") Then ' Dating
ActiveWorkbook.Worksheets("Main").Range("B16").Value =
result
ElseIf (resultTest = "0080924") Then ' Insulin
ActiveWorkbook.Worksheets("Main").Range("B19").Value =
String(1, result)
ElseIf (resultTest = "0080925") Then ' NTD
ActiveWorkbook.Worksheets("Main").Range("B20").Value =
String(1, result)
ElseIf (resultTest = "0080268") Then ' DIAMS
ActiveWorkbook.Worksheets("Main").Range("B13").Value =
result

' Ignore all other test numbers (e.g., X tests, Medians,
MoMs, Interpretation, EDC, etc.)
' These fields are calculated by the spreadsheet.
'
End If

iRow = iRow + 1
myRS.MoveNext
Loop

If (orderedTest = MS_ONLY) Then
ActiveWorkbook.Worksheets("Main").Range("B11").Value = ""
ActiveWorkbook.Worksheets("Main").Range("B12").Value = ""
ActiveWorkbook.Worksheets("Main").Range("B13").Value = ""
ElseIf (orderedTest = AFP_MS3) Then
ActiveWorkbook.Worksheets("Main").Range("B13").Value = ""
End If
ActiveWorkbook.Worksheets("Main").Range("B22").Value = "1"

ElseIf (orderedTest = MS_FT) Or (orderedTest = MS_SEQ1) Or
(orderedTest = MS_INT1) Then
' Switch to the FT Main worksheet
Worksheets("FT Main").Activate
ActiveSheet.Unprotect Password:="wkea"

' Accession Number
ActiveWorkbook.Worksheets("FT Main").Range("B5").Value = myRS(1)
' Patient Name
ActiveWorkbook.Worksheets("FT Main").Range("B6").Value = myRS(2)
' Date of Birth
ActiveWorkbook.Worksheets("FT Main").Range("B8").Value =
dateOfBirth
' Collection Date
ActiveWorkbook.Worksheets("FT Main").Range("B9").Value = _
ActiveWorkbook.Worksheets("Input").Range("E7").Value

' The following fields come from the individual test results
based upon the result test number.
iRow = 1
Do Until myRS.EOF
resultTest = myRS(4) ' Result Test Number
result = myRS(5) ' Result

If (resultTest = "0080917") Then ' Maternal Weight
ActiveWorkbook.Worksheets("FT Main").Range("B17").Value
= result
ElseIf (resultTest = "0080926") Then ' Race
ActiveWorkbook.Worksheets("FT Main").Range("B18").Value
= String(1, result)
ElseIf (resultTest = "0080927") Then ' Fetal Number
If ((String(1, result) = "U") Or (String(1, result) =
"0") Or (String(1, result) = "N")) Then
ActiveWorkbook.Worksheets("FT
Main").Range("B19").Value = "U"
ElseIf ((String(1, result) = "O") Or (String(1, result)
= "S")) Then
ActiveWorkbook.Worksheets("FT
Main").Range("B19").Value = "1"
ElseIf ((result = "TWO") Or (result = "TWINS")) Then
ActiveWorkbook.Worksheets("FT
Main").Range("B19").Value = "2"
ElseIf (result = "TRIPLETS") Then
ActiveWorkbook.Worksheets("FT
Main").Range("B19").Value = "3"
Else
ActiveWorkbook.Worksheets("FT
Main").Range("B19").Value = "U"
End If
ElseIf (resultTest = "0080935") Then ' hCG
ActiveWorkbook.Worksheets("FT Main").Range("B10").Value
= result
ElseIf (resultTest = "0081065") Then ' NT
ActiveWorkbook.Worksheets("FT Main").Range("B12").Value
= result
ElseIf (resultTest = "0081066") Then ' CRL
ActiveWorkbook.Worksheets("FT Main").Range("B20").Value
= result
ElseIf (resultTest = "0081067") Then ' PAPPA
ActiveWorkbook.Worksheets("FT Main").Range("B11").Value
= result
ElseIf (resultTest = "0081070") Then ' Sonographer
ActiveWorkbook.Worksheets("FT Main").Range("B23").Value
= result
ElseIf (resultTest = "0081071") Then ' Ultrasound Date
ActiveWorkbook.Worksheets("FT Main").Range("B24").Value
= result
ElseIf (resultTest = "0081158") Then ' Previous Downs
ActiveWorkbook.Worksheets("FT Main").Range("B25").Value
= String(1, result)

' Ignore all other test numbers (e.g., X tests, Medians,
MoMs, Sonographer #, Gest Used,
' Maternal Age, Interpretation, EDC, etc.). These are
calculated by the spreadsheet.
'
' The only fields we can't fill in are Date Method (FT
Main:B27)
' Insulin Dependent (FT
Main:B28)
' History of NTD (FT
Main:B29)
' and, if twins NT twin B (FT Main:B33)
' CRL twin B (FT
Main:B34)
End If

iRow = iRow + 1
myRS.MoveNext
Loop
Else
MsgBox "Ordered test '" & orderedTest & "' is not a supported
test.", vbCritical + vbOKOnly, "Unsupported Test"
End If

' Close the database
myRS.Close
Set myRS = Nothing
' Close the connection
myConnection.Close
Set myConnection = Nothing

Worksheets("Main").Protect Password:="wkea"
Worksheets("FT Main").Protect Password:="wkea"
End If

Exit Sub

He11:
MsgBox (myConnection.Errors.Item(0).Description)
End Sub
 
J

Jim Thomlinson

Sharing is a form of protection that limits what functaionallity you can and
can not use. As a result it is exteremly limiting when it comes to macros.
Welcome to one of those limits. If you want to use your code then you can not
share the workbook...
 
S

slcards

Thanks Jim. I was hoping that wasn't the answer, but I guess I'll have to
accept it!

Stuart
 
J

Jim Thomlinson

Sharing workbooks is done to give XL some degree of concurrent user access.
It is a band aid at best. Databases are much better at concurrencly where the
DBMS has a whole pile of built in abilities to deal with multiple user
access. Since you are managing ADODB I should think that you will be able to
work something out. Essentially use XL as the front end and SQL as your back
end. That means writing the data to SQL where it cna be shared but that is
not to bad to do (if the DBAs will give you access)...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

YYY-MM-DD format is changing when convert data to Flat File 3
Application.Quit Run-Time Error 1004 6
built myself into a corner, how to exit gracefully 3
ExecuteExcel4Macro 4
Run time error Method 'Range' of Object '_Worksheet' Failed 5
adds rows to all service groups except the first one 0
Run time 9 error for some users but not everyone 10
adding some rows in the middle of adding some other rows 3

Top