ganeshr
09-12-2011, 10:26 PM
can anyone there please convert this vba code to vb.net . . i ll be thankful to you if you help me.
Sub DrawAllPrecedents()
Dim rgFormulas As Excel.Range
Dim rgCell As Excel.Range
Set rgFormulas = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
For Each rgCell In rgFormulas
FindPrecedents rgCell
Next rgCell
End Sub
Sub FindPrecedents(rLast As Excel.Range)
Dim iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
rLast.ShowPrecedents
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
s = Selection.Address
Call Arrow(rLast, rLast.Worksheet.Range(s))
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub
Sub Arrow(rnStart As Range, rnEnd As Range)
Application.ScreenUpdating = False
With ActiveSheet.Shapes.AddLine(MOC(rnStart), MOC(rnStart, True), MOC(rnEnd), MOC(rnEnd, True)).Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(Red:=0, Green:=0, Blue:=280)
.BackColor.RGB = RGB(0, 0, 128)
End With
End Sub
Function MOC(R As Range, Optional Y As Boolean) As Long
If Y Then
MOC = R.Top + R.Height / 2
Else
MOC = R.Left + R.Width / 2
End If
End Function
Sub Clear_Shapes()
Dim i As Integer
Dim j As Integer
i = ActiveSheet.Shapes.Count
For j = 1 To i
ActiveSheet.Shapes(1).Select
Selection.Delete
Next j
End Sub
Function GetFormulaI(Cell As Range) As String
'Application.Volatile = True
If VarType(Cell) = 8 And Not Cell.HasFormula Then
GetFormulaI = "'" & Cell.Formula
Else
GetFormulaI = Cell.Formula
End If
If Cell.HasArray Then _
GetFormulaI = "{" & Cell.Formula & "}"
End Function
Sub DrawAllPrecedents()
Dim rgFormulas As Excel.Range
Dim rgCell As Excel.Range
Set rgFormulas = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
For Each rgCell In rgFormulas
FindPrecedents rgCell
Next rgCell
End Sub
Sub FindPrecedents(rLast As Excel.Range)
Dim iLinkNum As Integer, iArrowNum As Integer
Dim stMsg As String
Dim bNewArrow As Boolean
Application.ScreenUpdating = False
rLast.ShowPrecedents
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=True, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
If rLast.Worksheet.Parent.Name = ActiveCell.Worksheet.Parent.Name Then
If rLast.Worksheet.Name = ActiveCell.Parent.Name Then
' local
stMsg = stMsg & vbNewLine & Selection.Address
s = Selection.Address
Call Arrow(rLast, rLast.Worksheet.Range(s))
Else
stMsg = stMsg & vbNewLine & "'" & Selection.Parent.Name & "'!" & Selection.Address
End If
Else
' external
stMsg = stMsg & vbNewLine & Selection.Address(external:=True)
End If
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
MsgBox "Precedents are" & stMsg
Exit Sub
End Sub
Sub Arrow(rnStart As Range, rnEnd As Range)
Application.ScreenUpdating = False
With ActiveSheet.Shapes.AddLine(MOC(rnStart), MOC(rnStart, True), MOC(rnEnd), MOC(rnEnd, True)).Line
.EndArrowheadStyle = msoArrowheadTriangle
.EndArrowheadLength = msoArrowheadLengthMedium
.EndArrowheadWidth = msoArrowheadWidthMedium
.Transparency = 0#
.Visible = msoTrue
.ForeColor.RGB = RGB(Red:=0, Green:=0, Blue:=280)
.BackColor.RGB = RGB(0, 0, 128)
End With
End Sub
Function MOC(R As Range, Optional Y As Boolean) As Long
If Y Then
MOC = R.Top + R.Height / 2
Else
MOC = R.Left + R.Width / 2
End If
End Function
Sub Clear_Shapes()
Dim i As Integer
Dim j As Integer
i = ActiveSheet.Shapes.Count
For j = 1 To i
ActiveSheet.Shapes(1).Select
Selection.Delete
Next j
End Sub
Function GetFormulaI(Cell As Range) As String
'Application.Volatile = True
If VarType(Cell) = 8 And Not Cell.HasFormula Then
GetFormulaI = "'" & Cell.Formula
Else
GetFormulaI = Cell.Formula
End If
If Cell.HasArray Then _
GetFormulaI = "{" & Cell.Formula & "}"
End Function