'=========================================================
'==            Visual Basic Sample Code From            ==
'==     Microsoft Excel/Visual Basic for Windows 95     ==
'==                  Programmer's Guide                 ==
'==                      Chapter 4                      ==
'=========================================================

' DISCLAIMER OF WARRANTY

' THIS FILE CONTAINS UNDOCUMENTED SAMPLE CODE. THIS SAMPLE CODE IS 
' PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND. MICROSOFT FURTHER
' DISCLAIMS ALL IMPLIED WARRANTIES INCLUDING WITHOUT LIMITATION ANY
' IMPLIED WARRANTIES OF MERCHANTABILITY OR OF FITNESS FOR A PARTICULAR
' PURPOSE. THE ENTIRE RISK ARISING OUT OF THE USE OR PERFORMANCE OF THE
' SAMPLE CODE REMAINS WITH YOU.

' IN NO EVENT SHALL MICROSOFT OR ITS SUPPLIERS BE LIABLE FOR ANY DAMAGES
' WHATSOEVER (INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF
' BUSINESS PROFITS, BUSINESS INTERRUPTION, LOSS OF BUSINESS INFORMATION,
' OR OTHER PECUNIARY LOSS) ARISING OUT OF THE USE OF OR INABILITY TO USE
' THIS SAMPLE CODE, EVEN IF MICROSOFT HAS BEEN ADVISED OF THE POSSIBILITY
' OF SUCH DAMAGES. BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR
' LIMITATION OF LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE
' ABOVE LIMITATION MAY NOT APPLY TO YOU.






'=========================================================
'==                    From Page 66                     ==
'=========================================================

Sub Macro1()
	ActiveChart.ChartTitle.Select
	With Selection.Font
		.Name = "Times New Roman"
		.FontStyle = "Bold"
		.Size = 24
		.Strikethrough = False
		.Superscript = False
		.Subscript = False
		.OutlineFont = False
		.Shadow = False
		.Underline = xlNone
		.ColorIndex = xlAutomatic
		.Background = xlAutomatic
	End With
End Sub





'=========================================================
'==                    From Page 67                     ==
'=========================================================

Sub FormatChartTitle()
	With Charts("Chart1").ChartTitle.Font
		.FontStyle = "Bold"
		.Size = 24
	End With
End Sub





'=========================================================
'==                    From Page 68                     ==
'=========================================================

Worksheets("Sheet1").Range("A1").Value = 3.14159

'-------------------------------------------------

Worksheets("Sheet1").Range("A1").Value = _
	Worksheets("Sheet2").Range("B2").Value 

'-------------------------------------------------

myValue = Worksheets("Sheet1").Range("A1").Value

'-------------------------------------------------

MsgBox Worksheets("Sheet1").Range("A1").Value





'=========================================================
'==                    From Page 69                     ==
'=========================================================

Worksheets("Sheet1").Columns("A:D").AutoFit

'-------------------------------------------------

Worksheets("Sheet1").Range("A1:A10").Sort _
	Worksheets("Sheet1").Range("A1")

'-------------------------------------------------

Sub CheckWord()
	returnValue = Application.CheckSpelling("recieve")
	If returnValue = True Then
		MsgBox "The word is spelled correctly"
	Else
		MsgBox "The word is misspelled!"
	End If
End Sub





'=========================================================
'==                    From Page 70                     ==
'=========================================================

Workbooks.Open "BOOK2.XLS", , , , "drowssap"

'-------------------------------------------------

Workbooks.Open fileName:="BOOK2.XLS", password:="drowssap"

'-------------------------------------------------

Workbooks.Open password:="drowssap", fileName:="BOOK2.XLS"

'-------------------------------------------------

Sub CheckWord()
	returnValue = Application.CheckSpelling(word:="recieve")
	If returnValue = True Then
		MsgBox "The word is spelled correctly"
	Else
		MsgBox "The word is misspelled!"
	End If
End Sub





'=========================================================
'==                    From Page 71                     ==
'=========================================================

Sub NumWorksheets()
	MsgBox "Number of worksheets in this workbook: " & _
		ActiveWorkbook.Worksheets.Count
End Sub

'-------------------------------------------------

Sub HideEveryOther()
	For i = 1 To Worksheets.Count
		If i Mod 2 = 0 Then
			Worksheets(i).Visible = False
		End If
	Next i
End Sub





'=========================================================
'==                    From Page 72                     ==
'=========================================================

Public newSheet As Object

Sub CreateScratchWorksheet()
	Set newSheet = Worksheets.Add
	newSheet.Visible = xlVeryHidden
End Sub

Sub FillRanges()
	newSheet.Range("F9").Value = "some text"
	newSheet.Range("A1:D4").Formula = "=RAND()"
End Sub

Sub ShowValue()
	MsgBox newSheet.Range("A1").Value
End Sub

'-------------------------------------------------

Worksheets("Sheet1").Range("A1").Value = 3	' shorthand

Worksheets.Item("Sheet1").Range("A1").Value = 3	' same action

'-------------------------------------------------

Worksheets("Sheet1").Range("A1") = 3




'=========================================================
'==                    From Page 73                     ==
'=========================================================

Worksheets("Sheet1").Range("A1").Value = 3

'-------------------------------------------------

Dim mySheet As Object





'=========================================================
'==                    From Page 74                     ==
'=========================================================

Dim mySheet As Worksheet

'-------------------------------------------------

Sub ListSheetTypes()
	Dim mySheet As Worksheet
	For Each mySheet In ActiveWorkbook.Sheets
		MsgBox TypeName(mySheet)
	Next
End Sub

'-------------------------------------------------

Set myRange = Worksheets("Sheet1").Range("A1")

'-------------------------------------------------

Dim myRange As Object
myRange = Worksheets("Sheet1").Range("A1")	' error 91 occurs here

'-------------------------------------------------

myRange = Worksheets("Sheet1").Range("A1")	' forgot the Set statement!




'=========================================================
'==                    From Page 75                     ==
'=========================================================

Sub CloseWorkbooks()
	Dim wb As Workbook
	For Each wb In Application.Workbooks
		If wb.Name <> ThisWorkbook.Name Then
			wb.Close
		End If
	Next wb
End Sub





'=========================================================
'==                    From Page 76                     ==
'=========================================================

ActiveSheet.Cells(1, 1).Formula = "=SIN(180)"
ActiveSheet.Cells(1, 1).Font.Name = "Arial"
ActiveSheet.Cells(1, 1).Font.Bold = True
ActiveSheet.Cells(1, 1).Font.Size = 8

'-------------------------------------------------

With ActiveSheet.Cells(1, 1)
	.Formula = "=SIN(180)"
	.Font.Name = "Arial"
	.Font.Bold = True
	.Font.Size = 8
End With

'-------------------------------------------------

With ActiveSheet.Cells(1, 1)
	.Formula = "=SIN(180)"
	With .Font
		.Name = "Arial"
		.Bold = True
		.Size = 8
	End With
End With

'-------------------------------------------------

With ActiveSheet.TextBoxes
	.Font.Name = "Arial"
	.Font.Size = 8
End With





'=========================================================
'==                    From Page 78                     ==
'=========================================================

Sub SortRange()
Worksheets("Sheet1").Range("A1:B10").Sort _
	key1:=Range("A1"), order1:=xlDescending
End Sub

'-------------------------------------------------

Sub SortRange()
	Worksheets("Sheet1").Range("A1:B10").Sort _
		key1:=Worksheets("Sheet1").Range("A1"), order1:=xlDescending
End Sub





'=========================================================
'==                    From Page 79                     ==
'=========================================================

Sub RoundToZero()
	For rwIndex = 1 to 4
		For colIndex = 1 to 10
			If Worksheets("Sheet1").Cells(rwIndex, colIndex) < .01 Then
				Worksheets("Sheet1").Cells(rwIndex, colIndex).Value = 0
			End If
		Next colIndex
	Next rwIndex
End Sub

'-------------------------------------------------

Sub ListNames()
	Set newSheet = Worksheets.Add
	i = 1
	For Each nm In ActiveWorkbook.Names
		newSheet.Cells(i, 1).Value = nm.Name
		newSheet.Cells(i, 2).Value = "'" & nm.RefersTo
		i = i + 1
	Next nm
	newSheet.Columns("A:B").AutoFit
End Sub

'-------------------------------------------------

Set myObj = Worksheets("Sheet1").Range(Cells(1, 1), Cells(10, 4))





'=========================================================
'==                    From Page 80                     ==
'=========================================================

Sub DemoCells()
	rwMin = 1   ' the top row
	rwMax = 10  ' the bottom row
	colMin = 1  ' the left column
	colMax = 6  ' the right column
	Set TLCell = Worksheets("Sheet1").Cells(rwMin, colMin)
	Set BRCell = Worksheets("Sheet1").Cells(rwMax, colMax)
	Set myRange = Worksheets("Sheet1").Range(TLCell, BRCell)
	myRange.Value = "abc"
End Sub

'-------------------------------------------------

Sub ScanColumn()
	For Each c In Worksheets("Sheet1").Range("A1:A10").Cells
		If Application.IsText(c.Value) Then
			c.Offset(0, 1).Formula = "Text"
		ElseIf Application.IsNumber(c.Value) Then
			c.Offset(0, 1).Formula = "Number"
		ElseIf Application.IsLogical(c.Value) Then
			c.Offset(0, 1).Formula = "Boolean"
		ElseIf Application.IsError(c.Value) Then
			c.Offset(0, 1).Formula = "Error"
		ElseIf c.Value = "" Then
			c.Offset(0, 1).Formula = "(blank cell)"
		End If
	Next c
End Sub





'=========================================================
'==                    From Page 81                     ==
'=========================================================

Sub FormatRange()
	Set myRange = Worksheets("Sheet1").Range("A1").CurrentRegion
	myRange.NumberFormat = "0.0"
End Sub





'=========================================================
'==                    From Page 83                     ==
'=========================================================

Sub ConvertDates()
	Set myRange = ActiveSheet.UsedRange
	myRange.Columns("C").Insert
	Set dateCol = myRange.Columns("C")
	For Each c In dateCol.Cells
		If c.Offset(0, -1).Value <> "" Then
			c.FormulaR1C1 = "=RC[-2]+RC[-1]-(8/24)"
		End If
	Next c
	dateCol.NumberFormat = "mmm-dd-yyyy hh:mm"
	dateCol.Copy
	dateCol.PasteSpecial Paste:=xlValues
	myRange.Columns("A:B").Delete
	dateCol.AutoFit
End Sub





'=========================================================
'==                    From Page 84                     ==
'=========================================================

Sub RoundToZero()
	For Each r In Worksheets("Sheet1").Range("A1:D10").Cells
		If Abs(r.Value) < 0.01 Then
			r.Value = 0
		End If
	Next r
End Sub

'-------------------------------------------------

Sub RoundToZero()
	Worksheets("Sheet1").Activate
	On Error GoTo PressedCancel
	Set r = Application.InputBox( _
			prompt:="Select a range of cells", _
			Type:=8)
	On Error GoTo 0
	For Each c In r.Cells
		If Abs(c.Value) < 0.01 Then
			c.Value = 0
		End If
	Next c
	Exit Sub
	
PressedCancel:
	Resume
End Sub

'-------------------------------------------------

Sub RoundToZero()
	Set r = Worksheets("Sheet1").Range("A1").CurrentRegion
	For Each c In r.Cells
		If Abs(c.Value) < 0.01 Then
			c.Value = 0
		End If
	Next c
End Sub





'=========================================================
'==                    From Page 85                     ==
'=========================================================

Sub HideColumns()
	Set r = Worksheets("Sheet1").UsedRange
	For Each col In r.Columns
		If col.Column Mod 2 = 0 Then
			col.Hidden = True
		End If
	Next col
End Sub

'-------------------------------------------------

Sub HideColumns()
	Set r = Worksheets("Sheet1").UsedRange
	For i = 1 To r.Columns.Count
		If i Mod 2 = 0 Then
			r.Columns(i).Hidden = True
		End If
	Next i
End Sub

'-------------------------------------------------

Sub BuggyRemoveDuplicates()    ' DON'T USE THIS CODE!
	Worksheets("Sheet1").Range("A1").Sort _
		key1:=Worksheets("Sheet1").Range("A1")
	Set r = Worksheets("Sheet1").Range("A1").CurrentRegion.Columns("A")
	For Each c In r.Cells
		If c.Offset(1, 0).Value = c.Value Then
			c.Offset(1, 0).EntireRow.Delete
		End If
	Next c
End Sub





'=========================================================
'==                    From Page 86                     ==
'=========================================================

Sub GoodRemoveDuplicates()
	Worksheets("Sheet1").Range("A1").Sort _
			key1:=Worksheets("Sheet1").Range("A1")
	Set currentCell = Worksheets("Sheet1").Range("A1")
	Do While Not IsEmpty(currentCell)
		Set nextCell = currentCell.Offset(1, 0)
		If nextCell.Value = currentCell.Value Then
			currentCell.EntireRow.Delete
		End If
		Set currentCell = nextCell
	Loop
End Sub

'-------------------------------------------------

	Do While currentCell.Value <> ""
		' code here
	Loop

'-------------------------------------------------

Sub HideColumns()
	Set r = Worksheets("Sheet1").UsedRange
	MsgBox r.Address  ' debugging only!
	For i = 1 To r.Columns.Count
		If i Mod 2 = 0 Then
			r.Columns(i).Hidden = True
			MsgBox r.Columns(i).Address  ' debugging only!
		End If
	Next i
End Sub





'=========================================================
'==                    From Page 87                     ==
'=========================================================

Sub OpenBook1()
	Set myBook = Workbooks.Open(Filename:="BOOK1.XLS")
	MsgBox myBook.Worksheets(1).Range("A1").Value
End Sub

'-------------------------------------------------

Sub OpenBook1()
	EXEPath = Application.Path & Application.PathSeparator
	fName = EXEPath & "BOOK1.XLS"
	Set myBook = Workbooks.Open(Filename:=fName)
	MsgBox myBook.Worksheets(1).Range("A1").Value
End Sub





'=========================================================
'==                    From Page 88                     ==
'=========================================================

Sub OpenBook1()
	LibPath = Application.LibraryPath & Application.PathSeparator
	fName = LibPath & "BOOK1.XLS"
	Set myBook = Workbooks.Open(Filename:=fName)
	MsgBox myBook.Worksheets(1).Range("A1").Value
End Sub

'-------------------------------------------------

Sub DemoGetOpenFilename()
	Do
		fName = Application.GetOpenFilename
	Loop Until fName <> False
	MsgBox "Opening " & fName
	Set myBook = Workbooks.Open(Filename:=fName)
End Sub

'-------------------------------------------------

Sub CreateAndSave()
	Set newBook = Workbooks.Add
	Do
		fName = Application.GetSaveAsFilename
	Loop Until fName <> False
	newBook.SaveAs Filename:=fName
End Sub





'=========================================================
'==                    From Page 89                     ==
'=========================================================

Sub OpenChangeClose()
	Do
		fName = Application.GetOpenFilename
	Loop Until fName <> False
	Set myBook = Workbooks.Open(Filename:=fName)
	'
	' make some changes to myBook
	'
	myBook.Close savechanges:=False
End Sub

'-------------------------------------------------

Public DlgValue

Sub DisplayDialog()
	DlgValue = DialogSheets("Dialog1").Show
End Sub

'-------------------------------------------------

DlgValue = Workbooks("MYADDIN.XLA").DialogSheets("Dialog1").Show





'=========================================================
'==                    From Page 90                     ==
'=========================================================

Public DlgValue

Sub DisplayDialog()
	DlgValue = ThisWorkbook.DialogSheets("Dialog1").Show
End Sub


