A
and
Hi,
Does anyone know if it is possible to share a Windows developed template
with a user form and macros with people using Macs?
And if it is possible, how should I proceed? The user form code is
displayed below. I know this can be exchanged by e-mail (and copied and
pasted), but how about the user form layout? The buttons etcetera. And
how about the menu command for accessing these macros that this is in my
Windows template?
TIA,
H.
==================
User Form Code (some global variables are declared in the Module; not in
the user form, but that can be changed)
==================
Option Explicit
Const TagText = "AutoCorrect Backup Document"
Private Sub UserForm_Initialize()
frmAutoCorrect.Caption = strProcedureName & " - " & strVersion
End Sub
Private Sub btnBackup_Click()
Dim lngTeller As Long
frmAutoCorrect.Hide
Application.ScreenUpdating = False
Application.Documents.Add
lngTeller = GetAutoCorrectEntries()
With Selection
.SplitTable
.TypeText Text:=TagText
.TypeParagraph
End With
With ActiveDocument.Sentences(1)
.Bold = True
.Font.Size = 14
End With
Application.StatusBar = "Saving..."
If SaveACDoc = True Then
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
Application.ScreenUpdating = True
frmAutoCorrect.Show
End Sub
Private Sub btnClose_Click()
Unload Me
End Sub
Private Sub btnRestore_Click()
Dim ACFileName, Title As String
Dim MsgBoxButtons As Long, Response As Long, lngX As Long
frmAutoCorrect.Hide
MsgBoxButtons = vbYesNo + vbInformation + vbDefaultButton2
Title = strProcedureName & " - " & strVersion
Response = MsgBox("This will replace your current AutoCorrect entries
with entries from your backup document that contain the same name. Do
you wish to continue?", MsgBoxButtons, Title)
If Response = vbNo Then
GoTo bye:
End If
With Dialogs(wdDialogFileOpen)
.Name = "*.doc"
.Display
ACFileName = .Name
End With
If OpenACDoc(ACFileName) = True Then
lngX = RestoreACEntries()
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
bye:
System.Cursor = wdCursorNormal
frmAutoCorrect.Show
End Sub
Function RestoreACEntries()
Dim oDoc As Document, oACorrect As Object, oTable As Table, oRow As Row
Dim strName As String, strValue As String, strRTF As String, MyRange As
Range, RTFRange As Range
Dim lngX As Long
Err.Clear
On Error GoTo 0
If ActiveDocument.Words(1) = "AutoCorrect " Then
Set oDoc = ActiveDocument
Set oTable = oDoc.Tables(1)
Set oACorrect = Application.Autocorrect.Entries
Set MyRange = oTable.Cell(2, 1).Range
MyRange.End = MyRange.End - 1
System.Cursor = wdCursorWait
Do
Application.ScreenUpdating = False
strName = MyRange.Text
Set MyRange = MyRange.Next(wdCell)
MyRange.End = MyRange.End - 1
If Left$(Application.Version, 1) > "8" Then
If Not MyRange.Tables(1).Range.IsEqual(oTable.Range) Then
Application.Autocorrect.Entries.AddRichText strName,
MyRange
MyRange.Cut
If IsObjectValid(MyRange.Next(wdCell, 2)) Then
Set MyRange = MyRange.Next(wdCell, 2)
MyRange.End = MyRange.End - 1
GoTo NextLoop
Else
Exit Do
End If
End If
End If
strValue = MyRange.Text
Set RTFRange = MyRange.Next(wdCell)
RTFRange.End = RTFRange.End - 1
strRTF = RTFRange.Text
Application.StatusBar = "Adding AutoCorrect Entry: " & strName
If strRTF = "False" Then
Application.Autocorrect.Entries.Add Name:=strName,
Value:=strValue
Else
Application.Autocorrect.Entries.AddRichText strName, MyRange
End If
If IsObjectValid(RTFRange.Next(wdCell)) Then
Set MyRange = RTFRange.Next(wdCell)
MyRange.End = MyRange.End - 1
Else
Exit Do
End If
NextLoop:
Loop
System.Cursor = wdCursorNormal
Application.ScreenUpdating = True
MsgBox "Restore complete"
Else
MsgBox "This document is not in the correct format for an
AutoCorrect Backup document"
End If
RestoreACEntriesErrors:
Select Case Err.Number
Case 0:
Case Else
MsgBox ("There was an error. The document may be in the incorrect
format." & vbCr & Err.Number & " " & Err.Description & " " & strName)
End Select
End Function
Private Function GetAutoCorrectEntries()
Dim lngX As Long
Dim TotalACEntries As Long
Dim oRow As Row, MyRange As Range, oTable As Table, TestRange As Range
TotalACEntries = Application.Autocorrect.Entries.Count
Set oTable = ActiveDocument.Tables.Add(Range:=Selection.Range, _
NumRows:=(TotalACEntries + 1), NumColumns:=3)
Set MyRange = oTable.Cell(1, 1).Range
MyRange.Collapse
MyRange.Text = "Name"
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
MyRange.Text = "Value"
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
MyRange.Text = "RTF"
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
For lngX = 1 To TotalACEntries
MyRange.Text = Application.Autocorrect.Entries(lngX).Name
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
If Application.Autocorrect.Entries(lngX).RichText = True Then
Application.Autocorrect.Entries(lngX).Apply Range:=MyRange
Else
MyRange.Text = Application.Autocorrect.Entries(lngX).Value
End If
If Len(MyRange.Cells(1).Range.Text) = 2 Then
If Left$(Application.Version, 1) = "8" Then
MyRange.Text = "This entry couldn't be backed up because it
contained a table"
MsgBox "Entry " & Chr(34) &
Application.Autocorrect.Entries(lngX).Name & Chr(34) & " couldn't be
backed up, because it contained a table."
Else
Set MyRange = MyRange.Tables(1).Range
MyRange.Collapse wdCollapseEnd
End If
End If
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
MyRange.Text = Application.Autocorrect.Entries(lngX).RichText
If lngX < TotalACEntries Then
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
End If
Application.StatusBar = "Adding AutoCorrect Entry: " & lngX & " of
" & TotalACEntries
Next lngX
Set MyRange = Nothing
ActiveDocument.Range(0, 0).Select
End Function
Public Function SaveACDoc()
Dim MsgBoxButtons, Response As Long
Dim Title As String
SaveACDoc = True
Err.Clear
On Error GoTo SaveACDocErrors
With Dialogs(wdDialogFileSaveAs)
.Name = TagText
.Show
'ACFileName = .Name
End With
SaveACDocErrors:
Select Case Err.Number
Case 0:
Case 4198:
SaveACDoc = False
Case Else
MsgBoxButtons = vbYesNo + vbCritical + vbDefaultButton2 ' Define
buttons.
Title = Err.Number & " " & Err.Description
Response = MsgBox("There was an error. Do you want to want to
try again?", MsgBoxButtons, Title)
If Response = vbYes Then
Resume 'bring up SaveAs again
Else ' User choose No.
SaveACDoc = False
End If
End Select
End Function
Public Function OpenACDoc(ByVal ACFileOpenName As String) As Boolean
Dim MsgBoxButtons As Long
OpenACDoc = True
On Error GoTo OpenACDocErrors
Documents.Open Filename:=ACFileOpenName
On Error GoTo 0
Exit Function
OpenACDocErrors:
OpenACDoc = False
End Function
'************* btnDelAClist_Click() *****************
'Deletes all AutoCorrect entries from the list, after
'asking for confirmation first. HWA, January 28, 2004
Private Sub btnDelAClist_Click()
vResponse = MsgBox("This deletes all AutoCorrect entries! Continue?",
vbYesNo, strProcedureName)
If vResponse = vbNo Then
GoTo doei:
End If
Err.Clear
On Error GoTo AcErrors:
Application.ScreenUpdating = False
With Application.Autocorrect.Entries
While .Count > 0
.Item(1).Delete 'constant #1
Wend
End With
Application.ScreenUpdating = True
vResponse = MsgBox("All entries have been deleted.", vbInformation,
strProcedureName)
AcErrors:
Select Case Err.Number
Case 0:
Case Else
vResponse = MsgBox("Error deleting AutoCorrect entries." & vbCr &
"Error number: " & Err.Number & " " & Err.Description, vbCritical,
strProcedureName)
End Select
doei:
End Sub
Private Sub UserForm_Click()
End Sub
Does anyone know if it is possible to share a Windows developed template
with a user form and macros with people using Macs?
And if it is possible, how should I proceed? The user form code is
displayed below. I know this can be exchanged by e-mail (and copied and
pasted), but how about the user form layout? The buttons etcetera. And
how about the menu command for accessing these macros that this is in my
Windows template?
TIA,
H.
==================
User Form Code (some global variables are declared in the Module; not in
the user form, but that can be changed)
==================
Option Explicit
Const TagText = "AutoCorrect Backup Document"
Private Sub UserForm_Initialize()
frmAutoCorrect.Caption = strProcedureName & " - " & strVersion
End Sub
Private Sub btnBackup_Click()
Dim lngTeller As Long
frmAutoCorrect.Hide
Application.ScreenUpdating = False
Application.Documents.Add
lngTeller = GetAutoCorrectEntries()
With Selection
.SplitTable
.TypeText Text:=TagText
.TypeParagraph
End With
With ActiveDocument.Sentences(1)
.Bold = True
.Font.Size = 14
End With
Application.StatusBar = "Saving..."
If SaveACDoc = True Then
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
Application.ScreenUpdating = True
frmAutoCorrect.Show
End Sub
Private Sub btnClose_Click()
Unload Me
End Sub
Private Sub btnRestore_Click()
Dim ACFileName, Title As String
Dim MsgBoxButtons As Long, Response As Long, lngX As Long
frmAutoCorrect.Hide
MsgBoxButtons = vbYesNo + vbInformation + vbDefaultButton2
Title = strProcedureName & " - " & strVersion
Response = MsgBox("This will replace your current AutoCorrect entries
with entries from your backup document that contain the same name. Do
you wish to continue?", MsgBoxButtons, Title)
If Response = vbNo Then
GoTo bye:
End If
With Dialogs(wdDialogFileOpen)
.Name = "*.doc"
.Display
ACFileName = .Name
End With
If OpenACDoc(ACFileName) = True Then
lngX = RestoreACEntries()
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End If
bye:
System.Cursor = wdCursorNormal
frmAutoCorrect.Show
End Sub
Function RestoreACEntries()
Dim oDoc As Document, oACorrect As Object, oTable As Table, oRow As Row
Dim strName As String, strValue As String, strRTF As String, MyRange As
Range, RTFRange As Range
Dim lngX As Long
Err.Clear
On Error GoTo 0
If ActiveDocument.Words(1) = "AutoCorrect " Then
Set oDoc = ActiveDocument
Set oTable = oDoc.Tables(1)
Set oACorrect = Application.Autocorrect.Entries
Set MyRange = oTable.Cell(2, 1).Range
MyRange.End = MyRange.End - 1
System.Cursor = wdCursorWait
Do
Application.ScreenUpdating = False
strName = MyRange.Text
Set MyRange = MyRange.Next(wdCell)
MyRange.End = MyRange.End - 1
If Left$(Application.Version, 1) > "8" Then
If Not MyRange.Tables(1).Range.IsEqual(oTable.Range) Then
Application.Autocorrect.Entries.AddRichText strName,
MyRange
MyRange.Cut
If IsObjectValid(MyRange.Next(wdCell, 2)) Then
Set MyRange = MyRange.Next(wdCell, 2)
MyRange.End = MyRange.End - 1
GoTo NextLoop
Else
Exit Do
End If
End If
End If
strValue = MyRange.Text
Set RTFRange = MyRange.Next(wdCell)
RTFRange.End = RTFRange.End - 1
strRTF = RTFRange.Text
Application.StatusBar = "Adding AutoCorrect Entry: " & strName
If strRTF = "False" Then
Application.Autocorrect.Entries.Add Name:=strName,
Value:=strValue
Else
Application.Autocorrect.Entries.AddRichText strName, MyRange
End If
If IsObjectValid(RTFRange.Next(wdCell)) Then
Set MyRange = RTFRange.Next(wdCell)
MyRange.End = MyRange.End - 1
Else
Exit Do
End If
NextLoop:
Loop
System.Cursor = wdCursorNormal
Application.ScreenUpdating = True
MsgBox "Restore complete"
Else
MsgBox "This document is not in the correct format for an
AutoCorrect Backup document"
End If
RestoreACEntriesErrors:
Select Case Err.Number
Case 0:
Case Else
MsgBox ("There was an error. The document may be in the incorrect
format." & vbCr & Err.Number & " " & Err.Description & " " & strName)
End Select
End Function
Private Function GetAutoCorrectEntries()
Dim lngX As Long
Dim TotalACEntries As Long
Dim oRow As Row, MyRange As Range, oTable As Table, TestRange As Range
TotalACEntries = Application.Autocorrect.Entries.Count
Set oTable = ActiveDocument.Tables.Add(Range:=Selection.Range, _
NumRows:=(TotalACEntries + 1), NumColumns:=3)
Set MyRange = oTable.Cell(1, 1).Range
MyRange.Collapse
MyRange.Text = "Name"
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
MyRange.Text = "Value"
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
MyRange.Text = "RTF"
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
For lngX = 1 To TotalACEntries
MyRange.Text = Application.Autocorrect.Entries(lngX).Name
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
If Application.Autocorrect.Entries(lngX).RichText = True Then
Application.Autocorrect.Entries(lngX).Apply Range:=MyRange
Else
MyRange.Text = Application.Autocorrect.Entries(lngX).Value
End If
If Len(MyRange.Cells(1).Range.Text) = 2 Then
If Left$(Application.Version, 1) = "8" Then
MyRange.Text = "This entry couldn't be backed up because it
contained a table"
MsgBox "Entry " & Chr(34) &
Application.Autocorrect.Entries(lngX).Name & Chr(34) & " couldn't be
backed up, because it contained a table."
Else
Set MyRange = MyRange.Tables(1).Range
MyRange.Collapse wdCollapseEnd
End If
End If
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
MyRange.Text = Application.Autocorrect.Entries(lngX).RichText
If lngX < TotalACEntries Then
Set MyRange = MyRange.Next(wdCell)
MyRange.Collapse
End If
Application.StatusBar = "Adding AutoCorrect Entry: " & lngX & " of
" & TotalACEntries
Next lngX
Set MyRange = Nothing
ActiveDocument.Range(0, 0).Select
End Function
Public Function SaveACDoc()
Dim MsgBoxButtons, Response As Long
Dim Title As String
SaveACDoc = True
Err.Clear
On Error GoTo SaveACDocErrors
With Dialogs(wdDialogFileSaveAs)
.Name = TagText
.Show
'ACFileName = .Name
End With
SaveACDocErrors:
Select Case Err.Number
Case 0:
Case 4198:
SaveACDoc = False
Case Else
MsgBoxButtons = vbYesNo + vbCritical + vbDefaultButton2 ' Define
buttons.
Title = Err.Number & " " & Err.Description
Response = MsgBox("There was an error. Do you want to want to
try again?", MsgBoxButtons, Title)
If Response = vbYes Then
Resume 'bring up SaveAs again
Else ' User choose No.
SaveACDoc = False
End If
End Select
End Function
Public Function OpenACDoc(ByVal ACFileOpenName As String) As Boolean
Dim MsgBoxButtons As Long
OpenACDoc = True
On Error GoTo OpenACDocErrors
Documents.Open Filename:=ACFileOpenName
On Error GoTo 0
Exit Function
OpenACDocErrors:
OpenACDoc = False
End Function
'************* btnDelAClist_Click() *****************
'Deletes all AutoCorrect entries from the list, after
'asking for confirmation first. HWA, January 28, 2004
Private Sub btnDelAClist_Click()
vResponse = MsgBox("This deletes all AutoCorrect entries! Continue?",
vbYesNo, strProcedureName)
If vResponse = vbNo Then
GoTo doei:
End If
Err.Clear
On Error GoTo AcErrors:
Application.ScreenUpdating = False
With Application.Autocorrect.Entries
While .Count > 0
.Item(1).Delete 'constant #1
Wend
End With
Application.ScreenUpdating = True
vResponse = MsgBox("All entries have been deleted.", vbInformation,
strProcedureName)
AcErrors:
Select Case Err.Number
Case 0:
Case Else
vResponse = MsgBox("Error deleting AutoCorrect entries." & vbCr &
"Error number: " & Err.Number & " " & Err.Description, vbCritical,
strProcedureName)
End Select
doei:
End Sub
Private Sub UserForm_Click()
End Sub