it needs your help for making cad application

[Anonymous]

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