Correct. I meant to say it doesn't work in 2007, but does work in 2003. So
here's the code. Sorry, it is quite a bit. This is also my first big effort
in doing VBA, so the coding may not be ideal. I put a line of slashes
(/////) to separate code between objects. The post was too long, so I have
separated it into 2 posts.
///////////////////////////////////////////////////////////
'Microsoft Word Objects: Code for “ThisDocumentâ€
Private Sub Document_New()
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdPrintView
Else
ActiveWindow.View.Type = wdPrintView
End If
With Application
.WindowState = wdWindowStateMinimize
End With
If FormData.AccTextBox.Value = "" Then
MsgBox "You must fill out the necessary form data information.",
vbOKOnly + vbInformation, "Missing form data"
FormData.AccTextBox.SetFocus
FormData.Show
ElseIf FormData.PACSTextBox.Value = "" Then
MsgBox "You must fill out the necessary form data information.",
vbOKOnly + vbInformation, "Missing form data"
FormData.Show
FormData.PACSTextBox.SetFocus
ElseIf FormData.DirTextBox.Value = "" Then
MsgBox "You must fill out the necessary form data information.",
vbOKOnly + vbInformation, "Missing form data"
FormData.DirTextBox.SetFocus
FormData.Show
End If
InfoForm.Show
End Sub
Private Sub Document_Open()
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
ActiveWindow.ActivePane.View.Type = wdPrintView
Else
ActiveWindow.View.Type = wdPrintView
End If
Application.WindowState = wdWindowStateMaximize
If FormData.AccTextBox.Value = "" Then
MsgBox "You must fill out the necessary form data information.",
vbOKOnly + vbInformation, "Missing form data"
FormData.AccTextBox.SetFocus
FormData.Show
ElseIf FormData.PACSTextBox.Value = "" Then
MsgBox "You must fill out the necessary form data information.",
vbOKOnly + vbInformation, "Missing form data"
FormData.Show
FormData.PACSTextBox.SetFocus
ElseIf FormData.DirTextBox.Value = "" Then
MsgBox "You must fill out the necessary form data information.",
vbOKOnly + vbInformation, "Missing form data"
FormData.DirTextBox.SetFocus
FormData.Show
End If
End Sub
Private Sub Document_Close()
ActiveDocument.Saved = True
Application.DisplayAlerts = wdAlertsNone
End Sub
Private Sub FinishedBtn_Click()
CloseForm.Show
End Sub
Private Sub ManageFormBtn_Click()
FormData.Show
End Sub
Private Sub Application_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = True
End If
End Sub
///////////////////////////////////////////////////////////
‘Forms: Code for “CloseFormâ€
Private Sub SelectionBtn_Click()
On Error Resume Next
Dim blnEmailClient As Boolean
Dim strFileName, strDateTime, strDirPath, strHour, strMinute
If Hour(Now) < 10 Then
strHour = "0" & Hour(Now)
Else
strHour = Hour(Now)
End If
If Minute(Now) < 10 Then
strMinute = "0" & Minute(Now)
Else
strMinute = Minute(Now)
End If
strDateTime = Month(Now) & "." & Day(Now) & "." & Year(Now) & "_" &
strHour & "." & strMinute
strFileName = "OSF_" & strDateTime & ".doc"
If Not Right(strDir, 1) = "\" Then
strDirPath = FormData.DirTextBox.Value & "\"
Else
strDirPath = FormData.DirTextBox.Value
End If
Dim objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
If Not objFSO.FolderExists(strDir) Then
MsgBox "The folder set to save this document is missing." & vbCrLf _
& vbCrLf & "Please correct the location by clicking the Manage Form
Data button.", vbOKOnly + vbExclamation, "Missing Folder!"
Unload Me
Exit Sub
End If
blnEmailClient = False
strOutlookPath = "C:\Program Files\Microsoft Office\OFFICE12\Outlook.exe"
If objFSO.FileExists(strOutlookPath) Then
blnEmailClient = True
End If
If PatientStudyDoneBtn.Value = True Then
ActiveDocument.SaveAs (strDirPath & strFileName)
If blnEmailClient = True Then
Call Create_OL_Mail(FormData.AccTextBox.Value, _
"OSF - Ready for ACC numbers - " & ActiveDocument.Name, _
"<html><head></head><body>Click here to open the document:
<a href='file:///" & ActiveDocument.Path & "\" & ActiveDocument.Name & "'
title=" & strFileName & ">" & ActiveDocument.Name & "</a></body></html>")
Else
Call SendEmail("<fromaddress>", FormData.AccTextBox.Value, _
"OSF - Ready for ACC numbers - " & ActiveDocument.Name, _
"<html><head></head><body>Click here to open the document:
<a href='file:///" & ActiveDocument.Path & "\" & ActiveDocument.Name & "'
title=" & strFileName & ">" & ActiveDocument.Name & "</a></body></html>")
End If
Unload Me
If Word.Documents.Count = 1 Then
Word.Application.Quit (wdDoNotSaveChanges)
Else
ActiveDocument.Close (wdDoNotSaveChanges)
End If
ElseIf AccDoneBtn.Value = True Then
If Left(ActiveDocument.Name, 8) = "Document" Then
ActiveDocument.SaveAs (strDirPath & strFileName)
Else
ActiveDocument.Saved = False
ActiveDocument.Save
End If
If blnEmailClient = True Then
Call Create_OL_Mail(FormData.PACSTextBox.Value, _
"OSF - Ready for VI/iSite - " & ActiveDocument.Name, _
"<html><head></head><body>Click here to open the document:
<a href='file:///" & ActiveDocument.Path & "\" & ActiveDocument.Name & "'
title=" & strFileName & ">" & ActiveDocument.Name & "</a></body></html>")
Else
Call SendEmail("<fromaddress>", FormData.PACSTextBox.Value, _
"OSF - Ready for VI/iSite - " & ActiveDocument.Name, _
"<html><head></head><body>Click here to open the document:
<a href='file:///" & ActiveDocument.Path & "\" & ActiveDocument.Name & "'
title=" & strFileName & ">" & ActiveDocument.Name & "</a></body></html>")
End If
Unload Me
If Word.Documents.Count = 1 Then
Word.Application.Quit (wdDoNotSaveChanges)
Else
ActiveDocument.Close (wdDoNotSaveChanges)
End If
ElseIf PACSDoneBtn.Value = True Then
ActiveDocument.Save
Unload Me
If Word.Documents.Count = 1 Then
Word.Application.Quit (wdDoNotSaveChanges)
Else
ActiveDocument.Close (wdDoNotSaveChanges)
End If
ElseIf CloseNoChangesBtn.Value = True Then
Unload Me
ActiveDocument.Saved = True
Application.DisplayAlerts = wdAlertsNone
Word.Application.Quit (wdDoNotSaveChanges)
End If
Set objFSO = Nothing
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = True
End If
End Sub
Public Sub Create_OL_Mail(strMailTo, strSubject, strMessage)
On Error Resume Next
Dim olApp As Outlook.Application
Dim olMailItm As Outlook.MailItem
Set olApp = New Outlook.Application
' Create new OL mail item.
Set olMailItm = olApp.CreateItem(olMailItem)
With olMailItm
..BodyFormat = olFormatHTML
..To = strMailTo
..Subject = strSubject
..HTMLBody = strMessage
..Send 'Display or Send
'.Save
'.Close False
End With
'olApp.Quit
Set olApp = Nothing
Set olMailItm = Nothing
End Sub
Public Function SendEmail(strMailFrom, strMailTo, strSubject, strMessage)
On Error Resume Next
Const cdoSendUsingMethod =
"
http://schemas.microsoft.com/cdo/configuration/sendusing", _
cdoSendUsingPort = 2, _
cdoSMTPServer =
"
http://schemas.microsoft.com/cdo/configuration/smtpserver"
Dim iMsg, iConf, Flds
' Create the CDO connections.
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields
With Flds
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = "<smtpmailserver>"
.Update
End With
' Set the message properties.
With iMsg
Set .Configuration = iConf
.To = strMailTo
.From = strMailFrom
.Subject = strSubject
.TextBody = strMessage
End With
iMsg.HTMLBody = strMessage
On Error Resume Next
iMsg.Send ' send the message.
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Function
Private Sub CancelBtn_Click()
Unload Me
End Sub
 
///////////////////////////////////////////////////////////
‘Forms: Code for “FormDataâ€
Private Sub CancelBtn_Click()
Unload Me
End Sub
Private Sub FinishedBtn_Click()
On Error Resume Next
Dim quote
quote = Chr(34)
Set CodeMod = ThisDocument.VBProject.VBComponents("Module1").CodeModule
With CodeMod
.ReplaceLine 1, "Public Const strDir = " & quote & DirTextBox.Value
& quote
.ReplaceLine 2, "Public Const strAccEmail = " & quote &
AccTextBox.Value & quote
.ReplaceLine 3, "Public Const strPACSEmail = " & quote &
PACSTextBox.Value & quote
End With
Templates(1).Save
Me.Hide
End Sub
Private Sub UserForm_Initialize()
AccTextBox.Value = strAccEmail
PACSTextBox.Value = strPACSEmail
DirTextBox.Value = strDir
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = True
End If
End Sub
///////////////////////////////////////////////////////////
‘Forms: Code for “InfoFormâ€
Private Sub CancelBtn_Click()
Unload Me
Word.Application.Quit (wdDoNotSaveChanges)
End Sub
Private Sub ConsultNoBtn_Click()
ConsultTextBox.Value = ""
ConsultTextBox.Enabled = False
End Sub
Private Sub ConsultYesBtn_Click()
ConsultTextBox.Enabled = True
End Sub
Private Sub Cmdclose_Click()
Unload Me
End Sub
Private Sub ManageFormBtn_Click()
FormData.Show
End Sub
Private Sub UserForm_Initialize()
InfoForm.MedicalFacilityComboBox.List() = Array("Hospital 1", " Hospital
2", _
" Hospital 3", " Hospital 4", " Hospital 5", " Hospital 6", _
" Hospital 7", " Hospital 8", " Hospital 9")
With InfoForm.MonthComboBox
For i = 1 To 12
.AddItem i
Next i
End With
With InfoForm.DayComboBox
For i = 1 To 31
.AddItem i
Next i
End With
With InfoForm.YearComboBox
For i = Year(Now) - 105 To Year(Now) - 16
.AddItem i
Next i
End With
InfoForm.MonthComboBox.Value = Month(Now)
InfoForm.DayComboBox.Value = Day(Now)
InfoForm.YearComboBox.Value = Year(Now) - 60
InfoForm.ConsultTextBox.Enabled = False
End Sub
Private Sub FinishBtn_Click()
If NameTextBox.Value = "" Then
MsgBox "Please enter a patient name.", vbExclamation, "Error!"
InfoForm.NameTextBox.SetFocus
Exit Sub
ElseIf SSNTextBox1.Value = "" Then
MsgBox "Please enter a SSN.", vbExclamation, "Error!"
InfoForm.SSNTextBox1.SetFocus
Exit Sub
ElseIf SSNTextBox1.TextLength < 3 Then
MsgBox "Less than the required number of digits was entered for the
SSN. Please retry." _
, vbOKOnly + vbExlamation, "Error!"
InfoForm.SSNTextBox1.SetFocus
Exit Sub
ElseIf SSNTextBox2.TextLength < 2 Then
MsgBox "Less than the required number of digits was entered for the
SSN. Please retry." _
, vbOKOnly + vbExlamation, "Error!"
InfoForm.SSNTextBox2.SetFocus
Exit Sub
ElseIf SSNTextBox3.TextLength < 4 Then
MsgBox "Less than the required number of digits was entered for the
SSN. Please retry." _
, vbOKOnly + vbExlamation, "Error!"
InfoForm.SSNTextBox3.SetFocus
Exit Sub
ElseIf SSNTextBox2.Value = "" Then
MsgBox "Please enter a SSN.", vbExclamation, "Error!"
InfoForm.SSNTextBox2.SetFocus
Exit Sub
ElseIf SSNTextBox3.Value = "" Then
MsgBox "Please enter a SSN.", vbExclamation, "Error!"
InfoForm.SSNTextBox3.SetFocus
Exit Sub
ElseIf MonthComboBox.Value = "" Then
MsgBox "Please enter a date of birth.", vbExclamation, "Error!"
InfoForm.MonthComboBox.SetFocus
Exit Sub
ElseIf DayComboBox.Value = "" Then
MsgBox "Please enter a date of birth.", vbExclamation, "Error!"
InfoForm.DayComboBox.SetFocus
Exit Sub
ElseIf YearComboBox.Value = "" Then
MsgBox "Please enter a date of birth.", vbExclamation, "Error!"
InfoForm.YearComboBox.SetFocus
Exit Sub
ElseIf MedicalFacilityComboBox.Value = "" Then
MsgBox "Please enter a medical facility.", vbExclamation, "Error!"
InfoForm.MedicalFacilityComboBox.SetFocus
Exit Sub
ElseIf ConsultYesBtn.Value = True Then
If ConsultTextBox.Value = "" Then
MsgBox "Please enter a requestor.", vbExclamation, "Error!"
InfoForm.ConsultTextBox.SetFocus
Exit Sub
End If
ElseIf SourceTextBox.Value = "" Then
MsgBox "Please enter a source.", vbExclamation, "Error!"
InfoForm.SourceTextBox.SetFocus
Exit Sub
End If
ActiveDocument.Bookmarks("Name").Range.Text = NameTextBox.Value
ActiveDocument.Bookmarks("SSN").Range.Text = SSNTextBox1.Value & "-" &
SSNTextBox2.Value & "-" & SSNTextBox3.Value
ActiveDocument.Bookmarks("DOB").Range.Text = MonthComboBox.Value & "/" &
DayComboBox.Value & "/" & YearComboBox.Value
ActiveDocument.Bookmarks("Facility").Range.Text =
MedicalFacilityComboBox.Value
If ConsultNoBtn.Value = True Then
ActiveDocument.Bookmarks("ConsultRequest").Range.Text = "No"
ActiveDocument.Bookmarks("ConsultRequestor").Range.Text = ""
Else
ActiveDocument.Bookmarks("ConsultRequest").Range.Text = "Yes"
ActiveDocument.Bookmarks("ConsultRequestor").Range.Text =
ConsultTextBox.Value
End If
ActiveDocument.Bookmarks("Source").Range.Text = SourceTextBox.Value
InfoForm.Hide
StudyForm.Show
Exit Sub
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then
Cancel = True
End If
End Sub
Private Sub SSNTextBox1_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With SSNTextBox1
If .Text Like "*[!0-9]*" Then
Beep
SecondTime = True
..Text = LastText
..SelStart = LastPosition
Else
LastText = .Text
End If
End With
End If
SecondTime = False
End Sub
Private Sub SSNTextBox1_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
With SSNTextBox1
LastPosition = .SelStart
End With
End Sub
Private Sub SSNTextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With SSNTextBox1
LastPosition = .SelStart
End With
End Sub
Private Sub SSNTextBox2_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With SSNTextBox2
If .Text Like "*[!0-9]*" Then
Beep
SecondTime = True
..Text = LastText
..SelStart = LastPosition
Else
LastText = .Text
End If
End With
End If
SecondTime = False
End Sub
Private Sub SSNTextBox2_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
With SSNTextBox1
LastPosition = .SelStart
End With
End Sub
Private Sub SSNTextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With SSNTextBox2
LastPosition = .SelStart
End With
End Sub
Private Sub SSNTextBox3_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With SSNTextBox3
If .Text Like "*[!0-9]*" Then
Beep
SecondTime = True
..Text = LastText
..SelStart = LastPosition
Else
LastText = .Text
End If
End With
End If
SecondTime = False
End Sub
Private Sub SSNTextBox3_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
With SSNTextBox3
LastPosition = .SelStart
End With
End Sub
Private Sub SSNTextBox3_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With SSNTextBox3
LastPosition = .SelStart
End With
End Sub
Private Sub MonthComboBox_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With MonthComboBox
If .Text Like "*[!0-9]*" Then
Beep
SecondTime = True
..Text = LastText
..SelStart = LastPosition
Else
LastText = .Text
End If
End With
End If
SecondTime = False
End Sub
Private Sub MonthComboBox_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
With MonthComboBox
LastPosition = .SelStart
End With
End Sub
Private Sub MonthComboBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With MonthComboBox
LastPosition = .SelStart
End With
End Sub
Private Sub DayComboBox_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With DayComboBox
If .Text Like "*[!0-9]*" Then
Beep
SecondTime = True
..Text = LastText
..SelStart = LastPosition
Else
LastText = .Text
End If
End With
End If
SecondTime = False
End Sub
Private Sub DayComboBox_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
With DayComboBox
LastPosition = .SelStart
End With
End Sub
Private Sub DayComboBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With DayComboBox
LastPosition = .SelStart
End With
End Sub
Private Sub YearComboBox_Change()
Static LastText As String
Static SecondTime As Boolean
If Not SecondTime Then
With YearComboBox
If .Text Like "*[!0-9]*" Then
Beep
SecondTime = True
..Text = LastText
..SelStart = LastPosition
Else
LastText = .Text
End If
End With
End If
SecondTime = False
End Sub
Private Sub YearComboBox_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
With YearComboBox
LastPosition = .SelStart
End With
End Sub
Private Sub YearComboBox_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
With YearComboBox
LastPosition = .SelStart
End With
End Sub
