
Function Main As String

Dim Form, Page As Object
Dim Range, PageNum, Action, Text, ErrorMsg As String
Dim NPages, Res, i, Elem, NumEl, MaxNum, CorI, Res1 As Integer
Dim Mass(100) As Integer
Const Title = "Reorder Pages"

  NPages = ActiveDocument.Count
  If NPages > 99 Then
    Main = "Sorry, your document is already full."
    Exit Function
  End If
  If NPages = 1 Then
    Range = "1"
    PageNum = "1"
  else
    Range = "1-" + Str(NPages)
    PageNum = Str(NPages)
  End If
  Page = ActiveDocument.ActivePage
  For i = 1 to 100
    Mass(i) = 0
  Next i

  Form = ReadForm("Rdrpg.frm")
  do
    Form.SetStrValue("RangeBox", Range)
    Form.SetStrValue("PageNumBox", PageNum)
    If Form.ExecForm Then
      Range   = Form.GetStrValue("RangeBox")
      PageNum = Form.GetStrValue("PageNumBox")
      Action  = Form.GetStrValue("ActionBox")
    Else
      Main = "Cancelled"
      Exit Function
    End If
    ErrorMsg = ""
    Text = Range
    Res = CheckText(Text, Mass)
    If Res = 0 then
      ErrorMsg = "Enter correct sequence of positive numbers (e.g. 1,4-6,3)"
    Else
      If Res > 100 then
        ErrorMsg = "The count of pages is out of range (100 pages).  Enter smaller set of numbers."
      Else
        MaxNum = MaxElement(Mass, Res)
        If MaxNum > ActiveDocument.Count Then
          ErrorMsg = "Some of your entered pages are out of range."
        Else
          Text = PageNum
          RemoveSpaces(Text)
          Res1 = CheckNumber(Text)
          If Res1 = 0 then
            ErrorMsg = "Specified page number is invalid."
          Else
            If Res1 > ActiveDocument.Count then
              ErrorMsg = "Specified page number is too big."
            Else
              If Action = "Copy" then
                If ActiveDocument.Count + Res > 100 then
                  ErrorMsg = "The size of new document is out of range (1-100 pages). Enter smaller set of numbers."
                Else
                  CorI = 1
                End If
              Else
                If Action = "Move" then
                  CorI = 2
                End If
              End If
            End If
          End If
        End If
      End If
    End If
    If ErrorMsg <> "" Then
      MessageBox(ErrorMsg, Title, MBB_OK or MBI_EXCLAMATION)
    End If
  loop while ErrorMsg <> ""
  Res = Res - 1
  InsertPages(Mass, Res, Res1, CorI)
  Main = "Completed"
End Function

Function CheckNumber(Text As String) As Integer
Dim i As Integer
Dim SLet As String
	CheckNumber = 0
	For i = 1 to Len(Text)
		SLet = Mid(Text, i, 1)
		If Val(Slet) = 0.0 then exit Function
	Next i
	CheckNumber = Int(Val(Text))
End Function

sub InsertPages(ByRef Mass() As Integer, MassSize As Integer, ByVal CommitPageNum As Integer, ByVal CorI As Integer)
Dim NewPage, Draw, TempPage, MyPage, TempDoc, TempDoc1 As Object
Dim j, i, j1, j2, m, n As Integer
Dim CurDoc As Object
Dim TempMass(100) As Integer

	CurDoc = ActiveDocument
	If CurDoc.Count+MassSize = 100 then
		For i = 1 to MassSize
			j = Mass(i)
			NewPage = CurDoc.AddEmpty
			Draw = CurDoc.Item(j).Drawings
			Draw.LoadOnto(NewPage)
		Next i
		MyPage = CurDoc.Item(CommitPageNum)
		CurDoc.SetActivePage(MyPage)
		TempPage = CurDoc.Item(CurDoc.Count-MassSize+1)
		If CorI = 1 then
			For i = 1 to CurDoc.Count-MassSize-CommitPageNum
				NewPage = CurDoc.AddEmpty
				Draw = CurDoc.Item(CommitPageNum+1).Drawings
				Draw.LoadOnto(NewPage)
				Kill(CurDoc.Item(CommitPageNum+1))
				
			Next i
		Else
			For i = 1 to MassSize
				j = Mass(i)
				Kill(CurDoc.Item(j))
			Next i
			j1 = CurDoc.Index(MyPage)+1
			j2 = CurDoc.Index(TempPage)-1
			For i = j1 to j2
				NewPage =CurDoc .AddEmpty
				Draw = CurDoc.Item(j1).Drawings
				Draw.LoadOnto(NewPage)
				Kill(CurDoc.Item(j1))
			Next i
		End If
			
	Else
		TempDoc = Documents.AddEmpty
		If CorI = 1 then
			For i = 1 to CommitPageNum
				NewPage = TempDoc.AddEmpty
				Draw = CurDoc.Item(i).Drawings
				Draw.LoadOnto(NewPage)	
			Next i
			For i = 1 to MassSize
				j = Mass(i)
				NewPage = TempDoc.AddEmpty
				Draw = CurDoc.Item(j).Drawings
				Draw.LoadOnto(NewPage)
	
			Next i
			For i = CommitPageNum+1 to CurDoc.Count
				NewPage = TempDoc.AddEmpty
				Draw = CurDoc.Item(i).Drawings
				Draw.LoadOnto(NewPage)
			Next i
			
			Kill(TempDoc.Item(1))			
			TempDoc.SetActiveDocument
			TempDoc.SetActivePage(TempDoc.Item(CommitPageNum))
		Else
			MyPage = CurDoc.ActivePage
			TempPage = CurDoc.Item(CommitPageNum)
			TempDoc = Documents.AddEmpty
			For i = 1 to MassSize
				j = Mass(i)
				NewPage = TempDoc.AddEmpty			
				Draw = CurDoc.Item(j).Drawings
				Draw.LoadOnto(NewPage)
				
			Next i
			Kill(TempDoc.Item(1))
			j1 = CurDoc.Index(TempPage)
			For i = 1 to MassSize
				TempMass(i) = 1	
			Next i
			For i = 1 to MassSize
				j = Mass(i)
				If j <= j1 and TempMass(i) = 1 then
					j1 = j1-1
				End If
				If (j <= CurDoc.Count) and (TempMass(i) = 1) then
					Kill(CurDoc.Item(j))
					For m = 1 to MassSize
						If Mass(m) = j and TempMass(m) = 1 then TempMass(m) = 0
						If Mass(m) > j then Mass(m) = Mass(m) - 1
						
					Next m
				End If
				
			Next i
			TempDoc1 = Documents.AddEmpty
			
			If CurDoc <> NULL then
				For i =1 to j1
					NewPage = TempDoc1.AddEmpty
					Draw = CurDoc.Item(i).Drawings
					Draw.LoadOnto(NewPage)
				Next i
			End If
			
			For i = 1 to TempDoc.Count
				NewPage = TempDoc1.AddEmpty
				Draw = TempDoc.Item(i).Drawings
				Draw.LoadOnto(NewPage)
			Next i
			
			For i = j1+1 to CurDoc.Count
				NewPage = TempDoc1.AddEmpty
				Draw = CurDoc.Item(i).Drawings
				Draw.LoadOnto(NewPage)
			Next i
			Kill(TempDoc1.Item(1))
			TempDoc1.SetActiveDocument
			TempDoc1.SetActivePage(TempDoc1.Item(CommitPageNum))
			Kill(TempDoc)
		End If
	End If
	
	Kill(CurDoc)			
End sub

Function MaxElement (ByRef Mass() As Integer, MassSize As Integer) As Integer
Dim EL, i As Integer

	El = 1
	For i = 1 to MassSize-1
		If El <= Mass(i) then El = Mass(i)
	Next i
	MaxElement = El

End Function

Function CheckText(Text As String, ByRef Mass() As Integer) As Integer
Dim i, j, n, StartNum, EndNum, pos, Num As Integer
Dim TempStr, TempStr1, SLet, TrueSymbols As String
Dim Num1, s  As Integer
	Checktext = 0
	RemoveSpaces(Text)
	TrueSymbols = "0123456789,-"
	If Len(Text) = 0 then exit Function
	For i = 1 to Len(Text)
		SLet = Mid(Text, i, 1)
		If InStr(1, TrueSymbols, SLet) = 0 then
			Text = Text + ","
			exit Function
		End If
	Next i
	n = 1
	Num1 = 0
	TempStr = ""
	Text = Text+ ","
	For i = 1 to Len(Text)
		SLet = Mid(Text, i, 1)
		If SLet = "," then
			
			Num = Int(Val(TempStr))
			If Num > 0 and Num < 100 then
				If Num1 <> 0 then
					s = 1
					If Num1 > Num then s = -1
					j = Num1
					while j <> Num + s
						Mass(n) = j
						n = n+1
						j = j + s
						If n > 100 then exit do
					End while 
					Num1 = 0
					TempStr = ""
				Else 
					Mass(n) = Num
					n = n+1
					Num = 0
					TempStr = ""
				End If
			Else
				exit Function
			End If
		Else
			If SLet = "-" then
				If Num1 <> 0 then exit Function
				Num1 = Int(Val(TempStr))
				If Num1 < 1  or Num1 > 100 then exit Function
				TempStr = ""
			Else
				TempStr = TempStr + SLet
			End If
		End If

		If n > 100 then exit For
	Next i
	CheckText = n
End Function

Sub RemoveSpaces(Text As String)
Dim i, TextLen As Integer
Dim SLet, TempStr As String
	TextLen = Len(Text)
	TempStr = ""
	For i = 1 to TextLen
		SLet = Mid(Text, i, 1)
		If SLet <> " " then TempStr = TempStr + SLet
	Next i
	Text = TempStr
End Sub

