AutoCAD Map 3D General Discussion

AutoCAD Map 3D General Discussion

Reply
New Member
hipparcos
Posts: 1
Registered: ‎04-07-2013
Message 1 of 1 (108 Views)

it needs your help for making cad application

108 Views, 0 Replies
04-07-2013 10:57 PM

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.Description & vbCrLf & Err.Number
 


xlBook.Close Savechanges:=False
xlApp.Quit
' clean up
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End If
End Sub

추천 : 0
Announcements
Are you familiar with the Autodesk Expert Elites? The Expert Elite program is made up of customers that help other customers by sharing knowledge and exemplifying an engaging style of collaboration. To learn more, please visit our Expert Elite website.
Need installation help?

Start with some of our most frequented solutions or visit the Installation and Licensing Forum to get help installing your software.