following code is our galaxy's arm(near solar system ) 3d star map source code. it is called hipparcos catalog
it is cad's macro program
if excel file, vba code is comfiled you can see near solar sysem's star feature
for future human, for more easy access 3d map,
now it is need cad application program for using indiviually
my program is difficult for using
how can do for me ,in first ,difficultly by your help i can make it
in my off-duty time ,i make it but i am working, cad programe so difficult
if someong gether the effort , for everyone for easy program i will make
following source code
Option Explicit
Private Sub CommandButton1_Click()
Call DrawMeStarsEnd Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
frmDrawMeStars.Caption = "Go to Acad, draw the stars"
End Sub
Public Sub DrawMeStars()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRange As Excel.Range
Dim coeff As Integer '+1 or -1
Dim location(0 To 2) As Double
Dim pointobj As AcadPoint
Dim lngRows As Long
Dim lngCols As Long
Dim indx As Long
Dim jndx As Long
Dim ra As String 'orbit coordiate of earth
Dim dec As String 'declination (elevater)
Dim mas As String ' palallax(use to distance)
Dim radegree As Double 'ra degree
Dim decdegree As Double 'dec degree
Dim radtrad As Double 'ra degree to radian
Dim decdtrad As Double 'dec degree to radian
Dim dist As Double 'distance
MsgBox "Be patience, works slowly"
frmDrawMeStars.Hide
On Error Resume Next
Err.Clear ' clear any errors
Set xlApp = GetObject(, "Excel.application") ' See if Excel is running
If Err <> 0 Then ' ' If Excel not running start a new session
Err.Clear
Set xlApp = CreateObject("Excel.application") ' Start Excel if excel is not running
If Err <> 0 Then
MsgBox " Could not start Excel ! , Is Excel Installed ? ", vbCritical, " Excel Error ! "
Err.Clear
End If
End If
Err.Clear
On Error GoTo Err_Control
xlApp.DisplayAlerts = False
xlApp.Visible = True ' Make excel application visible
xlApp.WindowState = xlMinimized ' Minimize application window so we don't see it
Set xlBook = xlApp.Workbooks.Open(FileName:="c:\0to0.5mas.xls")
' Make Autocad window maximum
AcadApplication.WindowState = acMax
Set xlSheet = xlBook.Worksheets(1)
xlSheet.Activate ' make sheet 1 the active sheet
'
' get Excel data
'
Set xlRange = xlBook.ActiveSheet.UsedRange
lngRows = xlRange.Rows.Count
lngCols = xlRange.Columns.Count
Const pi = 3.14159265358979
Dim dataArr() As Variant
dataArr = xlRange.Value2
xlApp.DisplayAlerts = True
xlBook.Close Savechanges:=False
xlApp.Quit
' clean up
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
DoEvents
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
For lngRows = 3 To UBound(dataArr, 1) - 10
If dataArr(lngRows, 2) = "" Then
lngRows = lngRows + 4
End If
ra = dataArr(lngRows, 2)
dec = dataArr(lngRows, 3)
mas = dataArr(lngRows, 4)
If Mid(dec, 1, 1) = "-" Then coeff = -1 Else: coeff = 1
'calculating ra degree
radegree = 15 * CDbl(Mid(ra, 1, 2)) + 15 * CDbl(Mid(ra, 4, 2)) / 60 + 15 * Val(Mid(ra, 7, 6)) / 3600
'caculating dec degree
decdegree = CDbl(Mid(dec, 2, 2)) * coeff + CDbl(Mid(dec, 5, 2)) * coeff / 60 + Val(Mid(dec, 8, 6)) * coeff / 3600
'convert ra degree to radian
radtrad = (radegree / 180) * pi 'ra transferring from degree to radian
decdtrad = (decdegree / 180) * pi 'dec tranfering from degree to radian
dist = 3.26 * 1000 / CDbl(mas) ' calculating distance
'position of x,y z of location0=x,location1=y,location2=z
location(0) = dist * Cos(decdtrad) * Cos(radtrad)
location(1) = dist * Sin(radtrad) * Cos(decdtrad)
location(2) = dist * Sin(decdtrad)
Set pointobj = ThisDrawing.ModelSpace.AddPoint(location)
Next
ZoomAll
CommandButton2.SetFocus
CommandButton2.ForeColor = vbRed
frmDrawMeStars.Show
frmDrawMeStars.Caption = "Done"
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Descri
ption & vbCrLf & Err.Number
xlBook.Close Savechanges:=False
xlApp.Quit
' clean up
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End If
End Sub