I'm looking for the best way to perform a multiple-field validation on an access form. It is as simple as the field being null or not but the conditions are tricky. The criteria is not working, meaning it always moves to the else while leaving the required field(s) blank. I am a beginner in access and definitely in VB coding but here is what I have so far via google searching:
Private Sub EventSummaryPreview_Click()
If _
( _
Me.FRAUD_TYP = "Account Takeover" And _
Len([Form]![dbo_FPI_CASE_CEO Subform]![CEO_COMPANY_ID] & vbNullString) = 0 And _
Nz([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DT], 0 & vbNullString) = 0 And _
Len([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_CEO_USER_ID] & vbNullString) = 0 And _
Nz([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_AMT], 0 & vbNullString) = 0 And _
Len([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DEBIT_ACCT_NBR] & vbNullString) = 0 And _
Len(Me.NOTES & vbNullString) = 0 _
) Or _
( _
Me.FRAUD_TYP = "Account Takeover" And _
Len([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DT] & vbNullString) = 0 And _
Nz([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_AMT], 0 & vbNullString) = 0 And _
Len([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_KEY] & vbNullString) = 0 And _
Len(Me.NOTES & vbNullString) = 0 _
) _
Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
Else
CurrentDb.Execute "INSERT INTO dbo_FPI_CASE_ENRICHMENT (DC_NO, ENRICH_FLG, ENRICH_FLG_TS, ENRICH_STATUS) " _
& "VALUES (" & DC_NO & ", 1, Now(), 'OPEN')"
End If
End Sub
Any help is much appreciated.
Personally, I find it incredibly worthwhile to take the time to make something like this a tad more readable. You can do this by declaring multiple boolean variables and assigning them the values instead.
Dim cond1 as boolean, cond2 as boolean
Dim cond1A as boolean, cond1B as boolean, cond1C as boolean ' etc.,
Dim cond2A as boolean, cond2B as boolean, cond2C as boolean ' etc.,
' Breaking it down 1 by 1 helps you confirm that you have all of the proper criteria
' Putting these conditions in parenthesis will allow it to evaluate as true or false
cond1A = (Me.FRAUD_TYP = "Account Takeover")
cond1B = ((Len([Form]![dbo_FPI_CASE_CEO Subform]![CEO_COMPANY_ID] & vbNullString) = 0)
cond1C = (Nz([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DT], 0 & vbNullString) = 0)
etc.,
cond1 = (cond1A AND cond1B AND cond1C)
cond2 = (cond2A AND cond2B AND cond2C)
If cond1 or cond2 then
' If either are true then do this Action
else
' neither are true Action
endif
This may or may not have been the best way to accomplish my goal but here is the code I ended up with. I'll change to Archias' suggestion when I have another release, thanks to all who provided input!
If _
IsNull(Me.FRAUD_TYP.Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf (Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_KEY].Value)) Then
If Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DT].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_CEO_USER_ID].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_CEO Subform]![CEO_COMPANY_ID].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_AMT].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DEBIT_ACCT_NBR].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull(Me.NOTES) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
End If
ElseIf (Me.FRAUD_TYP = "Account Takeover" And Not IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_KEY].Value)) Then
If Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_CEO Subform]![CEO_COMPANY_ID].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_DT].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull([Form]![dbo_FPI_CASE_TRANS Subform]![TRANS_AMT].Value) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
ElseIf Me.FRAUD_TYP = "Account Takeover" And IsNull(Me.NOTES) Then
MsgBox "Required enrichment data elements are not populated, please correct your data."
OK = True
End If
Else
CurrentDb.Execute "INSERT INTO dbo_FPI_CASE_ENRICHMENT (DC_NO, ENRICH_FLG, ENRICH_FLG_TS, ENRICH_STATUS) " _
& "VALUES (" & DC_NO & ", 1, Now(), 'OPEN')"
End If
Related
i have done a connection using DSN, in which i have created a DSN throgh program. In that i have called a function to create a DSN, I dont want to call that function ecerytime i run the software, Instead i want to check whether dsn with the same name is already exist in the system or not, if it is not exist then only call to the function`
Public Sub ConnectDB(Con As ADODB.Connection)
Call CreatSQLDSN("TRDSN", VarSrvNm, VarDbName)
If Cn.State = 1 Then Cn.Close
On Error Resume Next
Con.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False;User ID=sa;Data Source=TRDSN;Initial Catalog='" & VarDbName & "'"
Con.Open Con.ConnectionString
If Err.Number <> 0 Then
If Err.Number = -2147467259 Then
If MsgBox(ServerName & " Server not Found. Connect to Other Server?", vbQuestion + vbDefaultButton2 + vbYesNo, "") = vbYes Then
PrintFile = Trim(Left(FindWindowPath, 3) & "DosPrint.Bat")
FileSystemObject.CreateTextFile PrintFile, True
Set TextStream = FileSystemObject.OpenTextFile(PrintFile, ForAppending)
TextStream.WriteLine "Del " & Left(FindWindowPath, 3) & "ServerName.dat"
TextStream.Close
Shell PrintFile, vbHide
End If
End
Else
If MsgBox(Err.Description, vbQuestion + vbOKOnly, "") = vbOK Then
Cancel = True
Exit Sub
End If
End If
End If
0
End Sub
Public Function CreatSQLDSN(SqlDsnName As String, SqlServerName As String, SqlDataName As String)
Dim Ret%, Driver$, Attributes$
Driver = "SQL Server" & Chr(0)
Attributes = "Server=" & SqlServerName & Chr(0)
Attributes = Attributes & "DSN=" & SqlDsnName & Chr(0)
Attributes = Attributes & "Database=" & SqlDataName & Chr(0)
Ret = SQLConfigDataSource(vbAPINull, ODBC_Add_User_DSN, Driver, Attributes)
'ret is equal to 1 on success and 0 if there is an error
If Ret <> 1 Then
MsgBox "User DSN Creation Failed"
End If
End Function`
A couple of options come to mind when needing to know if a DSN exists. You could either read through the Registry, or leverage your existing API call. I prefer the second option. It seems like a cleaner way to check for the existence of the DSN. Here is an example of what I am talking about:
Option Explicit
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" (ByVal hwndParent As Long, ByVal fRequest As Long, ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
Private Const ODBC_ADD_DSN = 1
Private Const ODBC_CONFIG_DSN = 2
Private Const ODBC_REMOVE_DSN = 3
Private Const ODBC_ADD_SYS_DSN = 4
Private Const ODBC_CONFIG_SYS_DSN = 5
Private Const ODBC_REMOVE_SYS_DSN = 6
Private Const ODBC_REMOVE_DEFAULT_DSN = 7
Private Sub cmdCreate_Click()
Dim VarSrvNm As String
Dim VarDbName As String
VarSrvNm = "MyServer"
VarDbName = "MyDB"
If Not SQLDSNExists("TRDSN", VarSrvNm, VarDbName) Then
If Not CreateSQLDSN("TRDSN", VarSrvNm, VarDbName) Then
MsgBox "User DSN Creation Failed"
End If
End If
End Sub
Public Function CreateSQLDSN(SqlDsnName As String, SqlServerName As String, SqlDataName As String) As Boolean
Dim Ret%, Driver$, Attributes$
Driver = "SQL Server" & Chr(0)
Attributes = "Server=" & SqlServerName & Chr(0)
Attributes = Attributes & "DSN=" & SqlDsnName & Chr(0)
Attributes = Attributes & "Database=" & SqlDataName & Chr(0)
Ret = SQLConfigDataSource(0&, ODBC_ADD_DSN, Driver, Attributes)
'ret is equal to 1 on success and 0 if there is an error
CreateSQLDSN = (Ret = 1)
End Function
Public Function SQLDSNExists(SqlDsnName As String, SqlServerName As String, SqlDataName As String) As Boolean
Dim Ret%, Driver$, Attributes$
Driver = "SQL Server" & Chr(0)
Attributes = "Server=" & SqlServerName & Chr(0)
Attributes = Attributes & "DSN=" & SqlDsnName & Chr(0)
Attributes = Attributes & "Database=" & SqlDataName & Chr(0)
Ret = SQLConfigDataSource(0&, ODBC_CONFIG_DSN, Driver, Attributes)
'ret is equal to 1 on success and 0 if there is an error
SQLDSNExists = (Ret = 1)
End Function
The main idea here is to try to modify the DSN you want to add. If the call fails, then the DSN does not exist.
With the following block of code, which accesses an html span element, I am unable to check for errors. When I leave the input box empty and press "ok," the value of Err.Number doesn't change. I have user error checking enabled (On Error Resume Next) and I am checking to make sure that Err.Number is not equal to 0 (an error is ocurring). The error is being thrown, but the value of Err.Number is not changing, and this happens both when On Error Resume Next is on as well as when it is off). By the way, what is the default value of Err.Number? How does that value differ from the value of Err.Number after the Err object is cleared? If I am doing anything wrong or stating any wrong information, please inform me.
On Error Resume Next
Dim updateRate
updateRate = 0
RatePrompt()
Sub RatePrompt
updateRate = InputBox("Please enter an update rate (milliseconds)", "Update Rate")
If Err <> 0 Then
Err.Clear()
MsgBox "No Input Was Specified. Please Specify An Input."
RatePrompt()
Else If updateRate > 2000 then
rateDecision = MsgBox ("Consider entering a lower update rate" & vbCrLf & "Would you like to revise update rate?", _
vbYesNo, "Quiclock Alert")
If rateDecision = vbYes then
RatePrompt()
End If
Else If updateRate < 0 then
MsgBox "Update Rate Not Valid. The Default Value of 0 Milliseconds Will Be Used."
updateRate = 0
Else If updateRate = "" then
MsgBox "Update Rate Adjustment Cancelled. The Default Value of 0 Milliseconds Will Be Used."
updateRate = 0
Else
End If
End If
End If
End If
End Sub
TimerStart()
Sub TimerStart
timerID = window.setTimeout("TimeUpdate", updateRate, "VBScript")
End Sub
Sub TimeUpdate
clockOutput.innerHTML = Time()
window.clearTimeout(timerID)
TimerStart()
End Sub
I have spent a large amount of time researching this problem, but have not come to a conclusion. Thanks for the help.
Try next logic skelet for your script:
Dim updateRate, rateRevision
updateRate = InputBox("Please enter an update rate (milliseconds)", "Update Rate")
If IsEmpty( updateRate) Then
'`Cancel` (or equivalent `Esc` or red `×`) pressed/clicked
Else
If IsNumeric( updateRate) Then
updateRate = CLng( updateRate) 'convert string to a Variant of subtype Long
If updateRate > 2000 Then
' do not bother a user by an additional input: offer a value change right now
rateRevision = InputBox ("Consider entering a lower update rate" _
& vbCrLf & "Would you like to revise update rate?", _
"Quiclock Alert", updateRate)
If IsNumeric( rateRevision) Then
rateRevision = CLng( rateRevision)
If rateRevision > 0 Then updateRate = rateRevision
Else
' keep the value > 2000
End If
ElseIf updateRate < 0 Then
updateRate = 0
Else
''
End If
Else
'non-numeric input, use e.g. default value of zero
updateRate = 0
End If
TimerStart()
End If
An explanation and observation to the code:
There is a mistake in the InputBox Function reference. In fact: if the user clicks Cancel (or the red × or presses Esc), then the function returns an empty value, which looks like a zero-length string ("") due to automatic subtype conversion. See the 32213674.vbs script output below.
Comparison Operators (VBScript) reference shows how expressions are compared or what results from the comparison, depending on the underlying subtype; particularly: if one expression is numeric and the other is a string then the numeric expression is less than the string expression.
32213674.vbs script:
option explicit
On Error GoTo 0
Dim sValInput
Call doOutput( True, sValInput)
Do While True
sValInput = InputBox( _
"Please enter any value (and `OK`) to see its features:" & vbCR _
& "a date-like value, e.g. " & FormatDateTime( Now, vbShortDate) & vbCR _
& "a time-like value, e.g. " & FormatDateTime( Now, vbShortTime) & vbCR _
& "a number-like value, e.g. 123456" & vbCR _
& "a string of your choice" & vbCR _
& "an empty string (i.e. only click `OK`)" & vbCR _
& "or press `Esc` or click red `×` or `Cancel` button to exit the loop" _
, "InputBox test loop")
Call doOutput( False, sValInput)
If IsEmpty( sValInput) Then Exit Do
Loop
Sub doOutput( bHeader, sVal)
If Instr(1, Wscript.FullName, "cscript.exe", vbTextCompare) > 0 Then
If bHeader Then
Wscript.Echo sHead()
Else
Wscript.Echo sLine( sVal)
End If
Else
If bHeader Then
Else
MsgBox( sHead() & vbCR & sLine( sVal))
End If
End If
End Sub
Function sHead()
sHead = "Empty?" & vbTab & "Number?" & vbTab & _
"Date?" & vbTab & "VarType" & vbTab & "TypeName" & "[value]"
End Function
Function sLine( sValue)
sLine = IsEmpty( sValue) & vbTab & IsNumeric( sValue) & vbTab & _
IsDate( sValue) & vbTab & VarType( sValue) & vbTab & _
TypeName( sValue) & vbTab & "[" & sValue & "]"
End Function
Output:
==>cscript //NOLOGO D:\VB_scripts\SO\32213674.vbs
Empty? Number? Date? VarType TypeName[value]
False False True 8 String [2015-08-26]
False False True 8 String [22:01:05]
False True False 8 String [123456]
False False False 8 String [qwertz]
False False False 8 String []
True True False 0 Empty []
I am getting empty msgBox when i call the function . Have a look on code as bellow
Public Function Custom(ByVal TableName As String, _
ByVal EmployeeCode As String, ByVal FieldName As String, ByVal DataToCheck As String, _
Optional ByVal CodeFieldName As String = Empty, Optional ByVal CodeFieldValue As String = Empty) As Boolean
Dim lstrSQL1 As String
Dim lrsTemp1 As ADODB.Recordset
lstrSQL1 = " Select " & FieldName & " from " & TableName & " Where ID_CARD_NO =" & DataToCheck & ""
'MsgBox (lstrSQL1)
If Len(Trim$(CodeFieldName)) <> 0 And Len(Trim$(CodeFieldValue)) <> 0 Then
lstrSQL1 = lstrSQL1 & " AND " & CodeFieldName & " <> '" & CodeFieldValue & "'"
End If
Set lrsTemp1 = cObjDBConn.ExecuteSQL(lstrSQL1)
If lrsTemp1 Is Nothing Then
Custom = False
ElseIf Not (lrsTemp1.BOF And lrsTemp1.EOF) Then
Custom = True
ElseIf lrsTemp1.RecordCount = 0 Then
Custom = False
Else
Custom = False
End If
If lrsTemp1.State = adStateOpen Then lrsTemp1.Close
Set lrsTemp1 = Nothing
Exit Function
ErrorHandle:
Custom = False
End Function
The calling code is here:
If gobjValidation.Custom(fstrTableName, gEmployeeCode, "EMPLOYEE_CODE", _
Trim$(TxtIDcardNo.text)) = True Then
MsgBox (gEmployeeCode)
Call MessageBox("This ID Number is already existing for another employee. Cannot enter duplicate number!Using By Employee Code:" & gEmployerCode & " ", OKOnly, Information, DefaultButton1, Me.Caption)
sstInformationTab.Tab = 0
As #Arvo said, you need to make youre EmployeeCode variable ByRef, then assign it a value in your function Custom()
Public Function Custom(ByVal TableName As String, _
**ByRef EmployeeCode As String**, ByVal FieldName As String, ByVal DataToCheck As String, _
Optional ByVal CodeFieldName As String = Empty, Optional ByVal CodeFieldValue As String = Empty) As Boolean
Dim lstrSQL1 As String
Dim lrsTemp1 As ADODB.Recordset
lstrSQL1 = " Select " & FieldName & " from " & TableName & " Where ID_CARD_NO =" & DataToCheck & ""
'MsgBox (lstrSQL1)
If Len(Trim$(CodeFieldName)) <> 0 And Len(Trim$(CodeFieldValue)) <> 0 Then
lstrSQL1 = lstrSQL1 & " AND " & CodeFieldName & " <> '" & CodeFieldValue & "'"
End If
Set lrsTemp1 = cObjDBConn.ExecuteSQL(lstrSQL1)
If lrsTemp1 Is Nothing Then
Custom = False
ElseIf Not (lrsTemp1.BOF And lrsTemp1.EOF) Then
Custom = True
**lrsTemp1.MoveFirst**
**EmployeeCode = lrsTemp1.Fields("EMPLOYEE_CODE")**
ElseIf lrsTemp1.RecordCount = 0 Then
Custom = False
Else
Custom = False
End If
If lrsTemp1.State = adStateOpen Then lrsTemp1.Close
Set lrsTemp1 = Nothing
Exit Function
ErrorHandle:
Custom = False
End Function
The double asterisks are just to highlight the changes I made to your original code.
I am new to VBA and my problem might be stupid, but I cant fix it, so please help me if you can!
Here is the thing: I got userform that fills spreadsheet perfectly, but if information is not entered it does crazy things. As you may see below i found some piece of code to check if the data is entered, so if its not window pops up and you have to enter something, but when you do form fills 2 rows of data instead of one. For example, if pick row 'x' and want to put values 'a','b','c','d', but forgot to put value 'c' then it shows an error and when i type missing value 'c' and press OK it creates row 'x' with values 'a','b',' ','d' and row 'x+1' with values 'a','b','c','d'.
Here is my code:
Private Sub cmdok_Click()
'next empty cell in column A
Set c = Range("a65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False 'speed up, hide task
'write userform entries to database
c.Value = Me.txtFname.Value
c.Offset(0, 3).Value = Me.txtngoals.Value
c.Offset(0, 28).Value = Me.cmbDiag.Value
If Me.optAcute.Value = "True" And Me.optchronic.Value = "False" Then
c.Offset(0, 29).Value = 1
c.Offset(0, 30).Value = ""
Else
c.Offset(0, 29).Value = ""
c.Offset(0, 30).Value = 1
End If
'input validation
If txtFname.Value = "" Then
MsgBox ("Sorry, you need to provide a Name")
txtFname.SetFocus
Exit Sub
End If
If txtngoals.Value = "" Then
MsgBox ("Sorry, you need to provide goals")
txtngoals.SetFocus
Exit Sub
End If
If cmbDiag.Value = "" Then
MsgBox ("Sorry, you need to provide Diagnosis")
cmbDiag.SetFocus
Exit Sub
End If
If optAcute.Value = optchronic.Value Then
MsgBox ("Sorry, you need to select Time since injury")
Exit Sub
End If
'clear the form
With Me
.txtFname.Value = vbNullString
.cmbDiag.Value = vbNullString
.optAcute.Value = vbNullString
.optchronic.Value = vbNullString
.txtngoals.Value = vbNullString
End With
Application.ScreenUpdating = True
End Sub
thank you in advance
Try moving the code "write userform entries to database" to after the validation checks.
Private Sub cmdok_Click()
'next empty cell in column A
Set c = Range("a65536").End(xlUp).Offset(1, 0)
Application.ScreenUpdating = False 'speed up, hide task
'input validation
If txtFname.Value = "" Then
MsgBox ("Sorry, you need to provide a Name")
txtFname.SetFocus
Exit Sub
End If
If txtngoals.Value = "" Then
MsgBox ("Sorry, you need to provide goals")
txtngoals.SetFocus
Exit Sub
End If
If cmbDiag.Value = "" Then
MsgBox ("Sorry, you need to provide Diagnosis")
cmbDiag.SetFocus
Exit Sub
End If
If optAcute.Value = optchronic.Value Then
MsgBox ("Sorry, you need to select Time since injury")
Exit Sub
End If
'write userform entries to database
c.Value = Me.txtFname.Value
c.Offset(0, 3).Value = Me.txtngoals.Value
c.Offset(0, 28).Value = Me.cmbDiag.Value
If Me.optAcute.Value = "True" And Me.optchronic.Value = "False" Then
c.Offset(0, 29).Value = 1
c.Offset(0, 30).Value = ""
Else
c.Offset(0, 29).Value = ""
c.Offset(0, 30).Value = 1
End If
'clear the form
With Me
.txtFname.Value = vbNullString
.cmbDiag.Value = vbNullString
.optAcute.Value = vbNullString
.optchronic.Value = vbNullString
.txtngoals.Value = vbNullString
End With
Application.ScreenUpdating = True
I'm changing some crufty old printing code to use the Visual Basic Print Dialog Control to pass printer information to a CrystalReport object. It works great except for one thing - the page selection box is consistently disabled no matter what flags I pass the object. Here is my code:
Public Enum PrintDialogFlags
NoFlag = 0
DisablePagesButton = 1
LoadIntoPrnObject = 2
AutoStartPrint = 4
End Enum
Public Function ShowPrintDialogCR(ByVal hwnd As Long, ByRef cr As CrystalReport, _
Optional PrintFlags As Long = 0) As Boolean
//this function assumes cr is a valid report object
On Error GoTo ShowPrintDialogCR_Error
Dim PD As New vbprndlglib.PrinterDlg
//load default settings
PD.PrinterName = Printer.DeviceName
PD.DriverName = Printer.DriverName
PD.Port = Printer.Port
PD.PaperBin = Printer.PaperBin
PD.CancelError = True
PD.flags = (vbprndlglib.cdlPDNoSelection Or vbprndlglib.cdlPDHidePrintToFile)
// commented the line below out to see if it was something with my logic
// Still disables page selection without this line
//If PrintFlags And DisablePagesButton Then PD.flags = PD.flags Or vbprndlglib.cdlPDNoPageNums
Printer.TrackDefault = False
PD.ShowPrinter (hwnd)
cr.PrinterPort = PD.Port
cr.PrinterDriver = PD.DriverName
cr.PrinterName = PD.PrinterName
cr.CopiesToPrinter = PD.Copies
If PD.flags And vbprndlglib.cdlPDPageNums Then
cr.PrinterStartPage = PD.FromPage
cr.PrinterStopPage = PD.ToPage
End If
If PrintFlags And PrintDialogFlags.LoadIntoPrnObject Then
//copy these settings to the printer object
Dim prn As Printer
For Each prn In Printers
If prn.DeviceName = PD.PrinterName Then
Set Printer = prn
Exit For
End If
Next prn
Printer.PaperBin = PD.PaperBin
Printer.PaperSize = PD.PaperSize
Printer.Duplex = PD.Duplex
Printer.Copies = PD.Copies
Printer.ColorMode = PD.ColorMode
Printer.Orientation = PD.Orientation
Printer.PrintQuality = PD.PrintQuality
End If
Set PD = Nothing
If PrintFlags And PrintDialogFlags.AutoStartPrint Then cr.Action = 1
ShowPrintDialogCR = True
Printer.TrackDefault = True
Exit Function
ShowPrintDialogCR_Error:
If Err.Number = 20545 Then //request cancelled by user
MsgBox "The print request was cancelled after being submitted to the print spooler." & vbNewLine & _
"If you cancelled a print to file dialog, this is a normal message. " & vbNewLine & _
"Otherwise, this message could mean your printer is not accepting print requests from us at this time." _
, vbOKOnly + vbExclamation, "Print Request Cancelled"
ErrorLogger Err, "ShowPrintDialogCR"
ElseIf Err.Number <> 32755 Then
//something else besides clicking cancel, show the error
MsgBox "Error " & Err.Number & " - " & Err.Description & vbNewLine & "Source: " & _
Err.Source & vbNewLine & vbNewLine & "Document not printed.", vbOKOnly + vbCritical, "Print Failure"
ErrorLogger Err, "ShowPrintDialogCR"
End If
Err.Clear
ShowPrintDialogCR = False
Printer.TrackDefault = False
End Function
I don't see what I'm doing wrong here. I've passed several combinations of unrelated flags just to see if the box would enable itself with no success. I've encountered VB6 quirks before and I'm really hoping this isn't one of them. Any help is much appreciated!
I found this in the KB article you linked to:
To enable the Select Pages portion of
the Print dialog box, Max must be set
to a number that is larger than Min.
So, at the very least, you need to set the Min and Max properties on the print dialog object to something reasonable before you set the flags:
PD.CancelError = True
'Set Min and Max to enable page selection'
PD.Min = 1
PD.Max = 32767 'Or any large number really'
PD.flags = (vbprndlglib.cdlPDNoSelection Or vbprndlglib.cdlPDHidePrintToFile)
In my own experimenting I also found out the following few things:
If you just set Min and Max, the page selection will default both the "To" and "From" fields to 1.
If you set Min to 1 and Max to -1, and also set FromPage to 1 and ToPage to -1, the "From" field will default 1 and the "To" field will be empty. It's interesting that this works since the documentation states that Max must be larger than Min, but it looks like -1 is treated more like an "empty" or "null" value.
If you set the vbPrnDlg.cdlPageNums flag, the Print Dialog will default to the Pages radio button when it's displayed. If you omit the vbPrnDlg.cdlPageNums flag, the dialog will default to the All radio button.