You are here:

Excel/Make profile in AutoCAD using excel sheet

Advertisement


Question
Hi,
I am an engineer and we are using a programmed Excel file to make profile and cross section of surveyed construction field. the file is made in 2003 and it matches with AutoCAd 2006. I need your help so that I can synchronize it in excel 2007 with CAD 2008 onward. below is the code which is originally made by a Japanese scholar.
thank you for your help in advance

Option Explicit
'-----------------------------------
'       WORKSHEETS
'-----------------------------------
Public wkName As String
Public wkNameRefP, wkNameRefT, wkNameRefF As String Public newSheet As Worksheet
'-----------------------------------
'       用紙サイズ(A0〜A4、Leagal〜Letter)
'-----------------------------------
Public strPprSize As String
Public A0, A1, A2, A3, A4, Letter, Leagal As String
'-----------------------------------
'       用紙規格(JIS、ISO)
'-----------------------------------
Rem Public strStandard As String
Public JIS, ISO As String
Public mgnOfXLeft As Single
Public mgnOfXRight As Single
Public mgnOfYHeight As Single
Public x, y As Single
'------------------------------------
'       縮尺
'------------------------------------
Public sclOfXAxis As Double          'x軸縮尺
Public sclOfYAxis As Double          'y軸縮尺
'------------------------------------
'       縦断フォーム変数
'------------------------------------
Public lengthOfTtlBnd As Single       '縦断帯の幅
Public hSpcLngth As Single          '帯間隔横幅
Public vSpcLngth As Single          '帯間隔縦幅
Public widthOfTtlBox As Single       'タイトルボックス幅
'------------------------------------
'       AutoCAD2000
'------------------------------------
Public AcadApp As AcadApplication
Public AcadDoc As AcadDocument
Public AcadMs As AcadModelSpace
Public txtStyle As AcadTextStyle
Public objLayer As AcadLayer
Public objiLayer As AcadLayer
Public AcadUtil As Object
Public attachmentPoint As AcAttachmentPoint


Public Sub MakeProfile()


Load frmMenu
   frmMenu.Show
   
   If frmMenu.IsOK = False Then
       Unload frmMenu
       Exit Sub
   End If
   
'MsgBox "選択された範囲は frmMenu.refProfile.Text でu。"       '選択範囲の表示Mostrar de Area limited donde ha seleccionado.
'MsgBox "選択された旗揚げ範囲は frmMenu.refFlags.Text でu。"          '選択範囲の表示
'MsgBox "選択されたタイトル範囲は、 frmMenu.refTitle.Text でu。"          '選択範囲の表示


'----------------------------------------------
'   ワークシートPlotSettingsからのデータのロード
'----------------------------------------------
wkName = "PlotSettings"

wkNameRefP = frmMenu.wkNameOfRefP
wkNameRefT = frmMenu.wkNameOfRefT
wkNameRefF = frmMenu.wkNameOfRefF

Rem Dim strStandard As String
Dim PprSize As String
Dim mgnOfXLeft, mgnOfXRight, mgnOfYHeight As Single
Dim lengthOfTtlBnd, heightOfTtlBnd As Single
Dim heightOfSprt, lengthOfHSpc, lengthOfVSpc As Single
Dim widthOfTtlBox As Single
Dim sclOfXAxis, sclOfYAxis As Single
Dim basicAltitude, maxAltitude, dividAltitude, dividNum As Single
Dim xo, yo As Single
Dim formatNum As String
Dim heightOfMtxt As Single
Dim heightOfTxt As Single
Dim mgnOfInstPt As Single
Dim mgnOfFlgs As Single
Dim heightOfAltMtxt As Single
Dim heightOfSclMtxt As Single


Rem strStandard = Worksheets(wkName).Cells(2, 4).Text   'PlotSettings"用紙規格"
strPprSize = Worksheets(wkName).Cells(2, 4).Text    'PlotSettings"用紙サイズ"
'------------ワークシート備考欄にて処理----------------------
'=worksheets(wkname).cells(3,4).text    'PlotSettings"綴じ"
'----------------------------------------------------------
mgnOfXLeft = Worksheets(wkName).Cells(4, 4).Value 'PlotSettings"図枠用余白 (a)"
mgnOfXRight = Worksheets(wkName).Cells(5, 4).Value 'PlotSettings"図枠用余白 (b)"
mgnOfYHeight = Worksheets(wkName).Cells(5, 4).Value 'PlotSettings"図枠用余白 (b)"
xo = Worksheets(wkName).Cells(6, 4).Value   'PlotSettings"x方向(図枠からの距離)"
yo = Worksheets(wkName).Cells(7, 4).Value   'PlotSettings"y方向(図枠からの距離)"
lengthOfTtlBnd = Worksheets(wkName).Cells(8, 4).Value
heightOfTtlBnd = Worksheets(wkName).Cells(9, 4).Value
heightOfSprt = Worksheets(wkName).Cells(10, 4).Value
lengthOfHSpc = Worksheets(wkName).Cells(11, 4).Value
lengthOfVSpc = Worksheets(wkName).Cells(12, 4).Value
widthOfTtlBox = Worksheets(wkName).Cells(13, 4).Value * 10
sclOfXAxis = Worksheets(wkName).Cells(14, 4).Value
sclOfYAxis = Worksheets(wkName).Cells(15, 4).Value
basicAltitude = Worksheets(wkName).Cells(16, 4).Value
maxAltitude = Worksheets(wkName).Cells(17, 4).Value
dividAltitude = Worksheets(wkName).Cells(18, 4).Value
dividNum = Worksheets(wkName).Cells(19, 4).Value

'cells(20,4)は未使用
'cells(21,4)は下段

heightOfMtxt = Worksheets(wkName).Cells(22, 4).Value

heightOfSclMtxt = Worksheets(wkName).Cells(23, 4).Value 'PlotSettings"縮尺用文字高"

heightOfTxt = Worksheets(wkName).Cells(24, 4).Value
heightOfAltMtxt = Worksheets(wkName).Cells(25, 4).Value     '標高値表記用文字高

formatNum = Worksheets(wkName).Cells(26, 4).Text
mgnOfInstPt = Worksheets(wkName).Cells(27, 4).Value

'=worksheets(wkname).cells(28,4).value  "PlotSettings"旗揚げ用文字高"

mgnOfFlgs = Worksheets(wkName).Cells(29, 4).Value


Select Case strPprSize
   Case "A0"
       x = 1189: y = 841          'A0:    1189 x 841mm(用紙サイズ横方向)
   Case "A1"
       x = 841: y = 594          'A1:    841 x 594mm
   Case "A2"
       x = 594: y = 420          'A2:    594 x 420mm
   Case "A3"
       x = 420: y = 297          'A3:    420 x 297mm
   Case "A4"
       x = 297: y = 210          'A4:    297 x 210mm
   Case "Letter"
       x = 266.7: y = 203.26     'Letter:  266.70 x 203.26mm (8_1/2 x 11 inch)
   Case "Leagal"
       x = 342.9: y = 203.2       'Leagal: 342.9 x 203.2mm (8_1/2 x 14 inch)
   Case "A0X2"
       x = 1682: y = 1189          'A0X2   1682 x 1189mm
   Case "A1X3"
       x = 1783: y = 841          'A1X3   1783 x 841mm
   Case "A2X3"
       x = 1261: y = 594          'A2X3   1261 x 594mm
   Case "A2X4"
       x = 1682: y = 594          'A2X4   1682 x 594mm
   Case "A2X5"
       x = 2102: y = 594          'A2X5   2102 x 594mm
   Case "A3X5"
       x = 1486: y = 420          'A3X5   1486 x 420mm
   Case "A3X6"
       x = 1783: y = 420          'A3X6   1783 x 420mm
   Case "A3X7"
       x = 2080: y = 420          'A3X7   2080 x 420mm
   Case "A4X5"
       x = 1051: y = 297          'A4X5   1051 x 297mm
   Case "A4X6"
       x = 1261: y = 297          'A4X6   1261 x 297mm
   Case "A4X7"
       x = 1471: y = 297          'A4X7   1471 x 297mm
   Case "A4X8"
       x = 1682: y = 297          'A4X8   1682 x 297mm
   Case "A4X9"
       x = 1892: y = 297          'A4X9   1892 x 297mm
End Select
   
'********************************************************************************
'下段の条件は、図枠幅をエクセルシートに与えたことにより削除uる

'If strStandard = "JIS" Then
   'If strPprSize = "A0" Or strPprSize = "A1" Then
       'mgnOfXLeft = 25: mgnOfXRight = 20: mgnOfYHeight = 20
   'ElseIf strPprSize = "A2" Or strPprSize = "A3" Or strPprSize = "A4" Then
       'mgnOfXLeft = 25: mgnOfXRight = 10: mgnOfYHeight = 10
   'End If

'ElseIf strStandard = "ISO" Then
   'If strPprSize = "A0" Or strPprSize = "A1" Then
       'mgnOfXLeft = 20: mgnOfXRight = 20: mgnOfYHeight = 20
   'ElseIf strPprSize = "A2" Or strPprSize = "A4" Or strPprSize = "Letter" Then
       'mgnOfXLeft = 10: mgnOfXRight = 10: mgnOfYHeight = 10
   'ElseIf strPprSize = "Leagal" Then
       'mgnOfXLeft = 15: mgnOfXRight = 10: mgnOfYHeight = 10
   'End If
'End If
'*********************************************************************************


'-----------------------------------------------------
'       AutoCAD 2004/5の起動
'-----------------------------------------------------
On Error Resume Next
   Set AcadApp = GetObject(, "AutoCAD.Application.16")
   If Error Then
       Set AcadApp = CreateObject("AutoCAD.Application.16")
       Error.Clear
   End If

AcadApp.Visible = True
   Set AcadDoc = AcadApp.ActiveDocument
   Set AcadMs = AcadDoc.ModelSpace

'----------------------------------------------------
'       図面全体に使用uる文字の設定
'----------------------------------------------------
   Dim currFontFile As String
   Dim newFontFile As String
   Dim slctdFont As String
   
   slctdFont = Worksheets(wkName).Cells(21, 4).Text & ".ttf"   'PlotSettings"使用フォント"
   
   On Error Resume Next
         Set txtStyle = AcadDoc.ActiveTextStyle
         newFontFile = "c:/Windows/Fonts/" & slctdFont
         txtStyle.fontFile = newFontFile
       If Error Then
         currFontFile = txtStyle.fontFile
         txtStyle.fontFile = currFontFile
       End If

'-------------------------------------------------------------------
'       レイヤーの設定(選択列+勾配+曲線帯+旗揚げ+図枠+タイトルを考慮uる)
'-------------------------------------------------------------------
   Dim LayerNum As Byte          'レイヤー枚数
   Dim addLayer As Byte          '基本レイヤー(勾配帯・タイトルボックス・図枠)
   Dim totalLayer As Byte          '総必要画層枚数
   
   Dim preposition As String          '画層名の設定
   Dim nameOfLayer As String       '画層名の設定
   Dim txtNum As Long
   
   Dim iLayer As Byte          '基本画層枚数(旗揚げ・図枠・タイトル)
   Dim pageOfLayer As Byte         '基本画層必要枚数
   Dim n(1 To 3) As String          '画層名
   
   
   addLayer = Abs(frmMenu.chkCurve.Value) + 1    '曲線帯+(*)旗揚げ+勾配帯+(*)図枠+(*)タイトル:    *マークは別途考慮
   totalLayer = frmMenu.nColsOfRefP + addLayer
   
   For LayerNum = 1 To totalLayer
       txtNum = Len(CStr(LayerNum))
         
         If txtNum = 2 Then
         preposition = "0"
         Else
         preposition = "00"
         End If
         
       nameOfLayer = preposition & LayerNum
       Set objLayer = AcadDoc.Layers.Add(nameOfLayer)
       '---------------------------------------------------------------------
       '   acRed=1, acYellow=2, acGreen=3, acCyan=4, acBlue=5, acMagenta=6, acWhite=7
       '---------------------------------------------------------------------
         With objLayer
         .Color = LayerNum
         .Linetype = 1
         End With
   Next LayerNum
       '-----------------------------------------
         '@Frm, ATitle, BFlags
       '-----------------------------------------
   n(1) = "Frm": n(2) = "Title": n(3) = "Flags"
   
   If frmMenu.chkFlags = -1 Then
       pageOfLayer = 3
   Else
       pageOfLayer = 2
   End If
         
   For iLayer = 1 To pageOfLayer
       Set objiLayer = AcadDoc.Layers.Add(n(CStr(iLayer)))
       With objiLayer
         If iLayer = 1 Then
         .Color = 9
         Else
         .Color = iLayer
         End If
         .Linetype = 1
       End With
   Next iLayer
   '*************************************************************************************
   '-------------------------------------------------------------------------------------
   '   ネスト構造で分岐させると、判断が多くなり処理時間がかかるため単純構造とした。まだ、一考の余地有り
   '-------------------------------------------------------------------------------------
   '*************************************************************************************
'------------------------------------------------------------------
'   縦断図書き始め
'------------------------------------------------------------------
'-----------------------------------------
'       図枠(A0〜Leagalサイズまで)
'-----------------------------------------
   Dim ix(0 To 4), iy(0 To 4) As Single        '図枠座標
   Dim exFrame, inFrame As Variant          '図枠作画名
   
   Dim xTB(0 To 4), yTB(0 To 4) As Single  '縦断タイトルバンド座標
   Dim xTD(0 To 4), yTD(0 To 4) As Single  '縦断データバンド座標
   Dim ttlFrame, dtFrame As Variant          '縦断タイトル・データバンド作画名


   Set AcadUtil = AcadDoc.Utility

       '--------------------------------
       '       図枠座標
       '--------------------------------
       ix(0) = mgnOfXLeft:      ix(1) = x - mgnOfXRight:    ix(2) = ix(1):          ix(3) = ix(0):     ix(4) = ix(0)
       iy(0) = mgnOfYHeight:   iy(1) = iy(0):          iy(2) = y - mgnOfYHeight:      iy(3) = iy(2):     iy(4) = iy(0)

       '------------------------------------
       '   縦断フォーム(タイトル・データバンド)座標
       '------------------------------------
       xTB(0) = mgnOfXLeft + xo:     xTB(1) = xTB(0) + lengthOfTtlBnd:   xTB(2) = xTB(1):          xTB(3) = xTB(0):     xTB(4) = xTB(0)
       yTB(0) = mgnOfYHeight + yo:  yTB(1) = yTB(0):          yTB(2) = yTB(0) + heightOfTtlBnd:   yTB(3) = yTB(2):     yTB(4) = yTB(0)

       xTD(0) = xTB(1) + lengthOfHSpc: xTD(1) = x - (mgnOfXRight + widthOfTtlBox + 2): xTD(2) = xTD(1): xTD(3) = xTD(0): xTD(4) = xTD(0)
       yTD(0) = yTB(0): yTD(1) = yTD(0): yTD(2) = yTD(0) + heightOfTtlBnd: yTD(3) = yTD(2): yTD(4) = yTD(0)

       With AcadUtil
         .CreateTypedArray exFrame, vbDouble, 0, 0, x, 0, x, y, 0, y, 0, 0
         .CreateTypedArray inFrame, vbDouble, ix(0), iy(0), ix(1), iy(1), ix(2), iy(2), ix(3), iy(3), ix(4), iy(4)
         .CreateTypedArray ttlFrame, vbDouble, xTB(0), yTB(0), xTB(1), yTB(1), xTB(2), yTB(2), xTB(3), yTB(3), xTB(4), yTB(4)
         .CreateTypedArray dtFrame, vbDouble, xTD(0), yTD(0), xTD(1), yTD(1), xTD(2), yTD(2), xTD(3), yTD(3), xTD(4), yTD(4)
       End With

   Dim objDtFrame As AcadLWPolyline
   Dim objTtlFrame As AcadLWPolyline
   Dim objinFrame As AcadLWPolyline
   Dim objexFrame As AcadLWPolyline
   
   AcadDoc.ActiveLayer = AcadDoc.Layers("Frm")
       
       Set objexFrame = AcadMs.AddLightWeightPolyline(exFrame)     '図枠作画
       Set objinFrame = AcadMs.AddLightWeightPolyline(inFrame)     '内側図枠作画
       
       If strPprSize = "A0" Or strPprSize = "A1" Then
         objinFrame.Lineweight = acLnWt140
       Else
         objinFrame.Lineweight = acLnWt100
       End If
       
       objinFrame.Update
       
       '*************************************************************************
       '以下のコードは、線の幅を与えるため、上記コードに変更
       '
       'With AcadMs
         '.AddLightWeightPolyline exFrame          '外側図枠作画
         '.AddLightWeightPolyline inFrame          '内側図枠作画
       'End With
       '**************************************************************************
   
       Set objTtlFrame = AcadMs.AddLightWeightPolyline(ttlFrame)       'タイトルバンド作画
         objTtlFrame.Color = acWhite          '線色の変更
       Set objDtFrame = AcadMs.AddLightWeightPolyline(dtFrame)         'データバンド作画
         objDtFrame.Color = acWhite          '線色の変更
   
         '-------------------------------------
         '       矩形配列複写
         '-------------------------------------
         Dim nRows, nCols, nLevs As Long
         Dim distRows, distCols, distLevs As Double
         Dim copyRctngl As Variant
         
         nRows = totalLayer: nCols = 1: nLevs = 1
         distRows = heightOfTtlBnd + lengthOfVSpc
         distCols = 1: distLevs = 1
         
         copyRctngl = objTtlFrame.ArrayRectangular(nRows, nCols, nLevs, distRows, distCols, distLevs)
         copyRctngl = objDtFrame.ArrayRectangular(nRows, nCols, nLevs, distRows, distCols, distLevs)
      
       '-----------------------------------
       '       x軸仕切り線
       '-----------------------------------
         Dim xSprtX(0 To 1), ySprtX(0 To 1) As Single
         Dim SprtLine As Variant
         Dim objSprtLine As AcadLWPolyline
         
         xSprtX(0) = xTB(0):          xSprtX(1) = xTD(1)
         ySprtX(0) = yTB(0) + distRows * totalLayer + heightOfSprt:    ySprtX(1) = ySprtX(0)

         AcadUtil.CreateTypedArray SprtLine, vbDouble, xSprtX(0), ySprtX(0), xSprtX(1), ySprtX(1)
         
         Set objSprtLine = AcadMs.AddLightWeightPolyline(SprtLine)
         objSprtLine.Color = acWhite
       
       '-----------------------------------
       '       y軸仕切り線
       '-----------------------------------
         Dim xSprtY(0 To 1), ySprtY(0 To 1) As Single
         Dim xSprtYi(0 To 1), ySprtYi(0 To 1) As Single
         Dim SprtLineP, SprtLineS As Variant
         Dim objSprtLineP, objSprtLineS As AcadLWPolyline
         Dim txtP(0 To 2) As Double          '型はDoubleでないと受け付けない(Singleの場合、作画不能)
         Dim txtOfAltitude As String
         Dim objMtxt As AcadMText
         Dim widthOfMtxt As Single
         Dim lengthOfSprtLineS As Single
         Dim iCounter As Single          '仕切線数
         Dim nCounter As Single          '標高値数
         Dim AltPreposition As String
         
         
         lengthOfSprtLineS = lengthOfTtlBnd * 0.7        '仕切線瀦さ(タイトル帯の70%とuる)
         
         xSprtY(0) = xTD(0):          xSprtY(1) = xSprtY(0)          '仕切り線開始座標
         ySprtY(0) = ySprtX(0):      ySprtY(1) = ySprtY(0) + (maxAltitude - basicAltitude) * 10 ^ 3 / sclOfYAxis   '仕切り線終点座標(指定スケール時のy軸瀦さ)
         xSprtYi(0) = xTD(0) - lengthOfSprtLineS: xSprtYi(1) = xTD(0)
         
         With AcadUtil
         .CreateTypedArray SprtLineP, vbDouble, xSprtY(0), ySprtY(0), xSprtY(1), ySprtY(1)
         Set objSprtLineP = AcadMs.AddLightWeightPolyline(SprtLineP)
         objSprtLineP.Color = acWhite

         For iCounter = 1 To dividNum
         '---仕切り線座標---
         ySprtYi(0) = ySprtX(0) + (dividAltitude * 10 ^ 3 / sclOfYAxis) * iCounter: ySprtYi(1) = ySprtYi(0)

         .CreateTypedArray SprtLineS, vbDouble, xSprtYi(0), ySprtYi(0), xSprtYi(1), ySprtYi(1)
         Set objSprtLineS = AcadMs.AddLightWeightPolyline(SprtLineS)
         objSprtLineS.Color = acWhite
         Next iCounter
         
         End With
         
         '---------------------
         '***仕切標高値の記入***
         '---------------------
         txtP(0) = xSprtYi(0)        '標高値(x座標)
         txtP(2) = 0          '標高値(z座標)
 
         widthOfMtxt = lengthOfSprtLineS - lengthOfHSpc      'マルチテキスト対象幅
 
         For nCounter = 0 To dividNum
         
         If nCounter = 0 Then
         AltPreposition = "DL= "
         Else
         AltPreposition = ""
         End If
         
         txtP(1) = ySprtX(0) + (dividAltitude * 10 ^ 3 / sclOfYAxis) * nCounter + heightOfAltMtxt + lengthOfVSpc / 2  '標高値(y座標)
         txtOfAltitude = AltPreposition & Format(basicAltitude + dividAltitude * nCounter, formatNum)
         Set objMtxt = AcadMs.AddMText(txtP, widthOfMtxt, txtOfAltitude)
         With objMtxt
         .Color = acGreen
         .attachmentPoint = acAttachmentPointTopRight
         .Height = heightOfAltMtxt
         .Update
         End With
         
         Next nCounter
       
       
       '------------------------------------
       '       縮尺の表示
       '------------------------------------
         Dim triPoint(0 To 7) As Double          '三角形の座標:Double型でないとポリラインが作画できない(Single型では拒否)
         Dim widthOfTriTxt As Double          '縮尺項目における文字幅
         Dim horizontalMtxt, verticalMtxt As String  'x軸スケール値、y軸スケール値
         Dim instPh(0 To 2) As Double     '縮尺値の座標:Double型でないと記入できない(Single型では拒否)
         Dim instPv(0 To 2) As Double    'instPhとinstPvを併記[instPh(0 to 2), instPv(0 to 2) as Double]uると前記のものが機能しない
         
         Dim objTriPl As AcadLWPolyline
         Dim objVerMTxt, objHorMtxt As AcadMText


         '---三角形の座標---
         triPoint(0) = xTB(0) + lengthOfHSpc          '三角形始点x座標
         triPoint(1) = ySprtX(0) + heightOfMtxt + heightOfSprt + lengthOfVSpc    '三角形始点y座標
         triPoint(2) = Application.WorksheetFunction.Round(triPoint(0) + lengthOfTtlBnd * 0.3, 0)    'タイトル帯の(1-0.7)*100%考慮
         triPoint(3) = triPoint(1)
         triPoint(4) = triPoint(2)
         triPoint(5) = Application.WorksheetFunction.Round(triPoint(1) + (dividAltitude * 10 ^ 3 / sclOfYAxis) * 0.5, 0)     '仕切線間隔の1/2を考慮
         triPoint(6) = triPoint(0)       '三角形終点x座標
         triPoint(7) = triPoint(1)       '三角形終点y座標
         
         Set objTriPl = AcadMs.AddLightWeightPolyline(triPoint)      '三角形の作画
         objTriPl.Color = acWhite
         
         '---縮尺値の書式設定---
         widthOfTriTxt = triPoint(2) - triPoint(0)   '文字幅(三角形底辺瀦さとuる)
         horizontalMtxt = "1 : " & CStr(sclOfXAxis)        'x軸スケール
         verticalMtxt = "1 : " & CStr(sclOfYAxis)          'y軸スケール
         
         '---縮尺値の記入点座標
         instPh(0) = triPoint(0): instPh(1) = triPoint(1) - lengthOfVSpc / 2: instPh(2) = 0 'x軸スケール値記入点座標
         instPv(0) = triPoint(2) + lengthOfHSpc / 2: instPv(1) = triPoint(1) + (triPoint(5) - triPoint(1) - widthOfTriTxt) / 2: instPv(2) = 0 'y軸スケール値記入点座標
         '---文字幅は底辺瀦さで決定されるため、y軸中心位置に文字が配置されるようにした。
         
         Set objHorMtxt = AcadMs.AddMText(instPh, widthOfTriTxt, horizontalMtxt)
         Set objVerMTxt = AcadMs.AddMText(instPv, widthOfTriTxt, verticalMtxt)
         
         
       
         '---x軸縮尺値(objHorMtxt)について---
         With objHorMtxt
         .Color = acGreen
         .attachmentPoint = acAttachmentPointTopCenter
         .Height = heightOfSclMtxt
         .Update
         End With
         
         '---y軸縮尺値(objVerMtxt)について
         With objVerMTxt
         .Color = acGreen
         .attachmentPoint = acAttachmentPointTopCenter
         .Rotate instPv, dtr(90)
         .Height = heightOfSclMtxt
         .Update
         End With

'****************************
'----------------------------
'3/17ここまで終了
'----------------------------
'****************************

   '--------------------------------------------------
   '   帯タイトルの記入:基本的に一動作(Draw)で一枚作画
   '--------------------------------------------------
       
 'Case@:   縦断タイトルを含んだデータの作画・・・・・・・・・・・OK
 'CaseA:  Case@+曲線帯の追加・・・・・・・・・・・・・・・・・・・・・OK
 'CaseB:  2枚目以降(縦断タイトルの選択)の作画・・・・・OK
 'CaseC:  CaseB+曲線帯の追加・・・・・・・・・・・・・・・・・・OK
 'CaseD:  旗揚げが選択されている場合
 
       Dim nTxt As Double
       Dim nCol As Double
       Dim nRow As Double
       Dim txtOfTtlBnd As String
       Dim PtOfTtlBnd(0 To 2) As Double
       Dim addCnt_1, addCnt_2 As Double
       Dim ntxtNum As Long
       Dim sColOfRef, eColOfRef As Double

       Dim addCnt, addCnt_Ttl As Double        '縦断データ用

       
   Select Case frmMenu.chkReDrawing.Value  'True=-1, False=0
       
       Case 0
         nRow = frmMenu.sRowOfRefP
         sColOfRef = frmMenu.sColOfRefP
         eColOfRef = frmMenu.eColOfRefP
         wkName = wkNameRefP
         
         '<作画開始点条件>
         addCnt_Ttl = 1      '縦断データ用
         
       Case -1
         nRow = frmMenu.sRowOfRefT
         sColOfRef = frmMenu.sColOfRefT
         eColOfRef = frmMenu.eColOfRefT
         wkName = wkNameRefT
         
         '<作画開始点条件>
         addCnt_Ttl = 0      '縦断データ用
         
   End Select


   Select Case frmMenu.chkCurve
       
       Case 0
         addCnt_1 = 0
         '<曲線帯の追加条件>
         addCnt = 0      '縦断データ用
       
       Case -1
         addCnt_1 = 1
         '<曲線帯の追加条件>
         addCnt = 1      '縦断データ用
   
   End Select
   
   
   Select Case frmMenu.chkFlags
       
       Case 0
       
       Case -1
   
   End Select
         
         
       For nTxt = sColOfRef To eColOfRef + addCnt_1
         
         ntxtNum = Len(CStr(nTxt))
         
         If ntxtNum = 2 Then
         preposition = "0"
         Else
         preposition = "00"
         End If
         
       Set objLayer = AcadDoc.Layers.Item(preposition & (nTxt - sColOfRef + 1))
         AcadDoc.ActiveLayer = objLayer
         
         If addCnt_1 = 0 Then
         
         If nTxt = eColOfRef + addCnt_1 Then
         txtOfTtlBnd = "Slope"   'とり えず小文字のみの表示
         'addCnt_2 = 1
         Else
         txtOfTtlBnd = Worksheets(wkName).Cells(nRow, nTxt).Text
         addCnt_2 = 0
         End If
         
         ElseIf addCnt_1 = 1 Then
         
         If nTxt = sColOfRef Then
         txtOfTtlBnd = "Curve"      'とり えず小文字のみの表示
         addCnt_2 = 0
         ElseIf nTxt = eColOfRef + 1 Then
         txtOfTtlBnd = "Slope"       'とり えず小文字のみの表示
         addCnt_2 = 0
         Else
         txtOfTtlBnd = Worksheets(wkName).Cells(nRow, nTxt - 1).Text
         addCnt_2 = 0
         End If
         End If
         
       PtOfTtlBnd(0) = xTB(0) + lengthOfHSpc
       PtOfTtlBnd(1) = yTB(0) + heightOfTtlBnd / 2 + heightOfMtxt / 2 + (heightOfTtlBnd + lengthOfVSpc) * (nTxt - sColOfRef - addCnt_2)
       PtOfTtlBnd(2) = 0
         
       Set objMtxt = AcadMs.AddMText(PtOfTtlBnd, lengthOfTtlBnd - lengthOfHSpc, txtOfTtlBnd)
         objMtxt.attachmentPoint = acAttachmentPointTopLeft   '何ゆえ、センターに表示されないか謎????
         objMtxt.Height = heightOfMtxt
         objMtxt.Color = acGreen
         objMtxt.Update
         
       Next nTxt
   
'--------------------------------------------------------------
'   縦断データの記載
'--------------------------------------------------------------
         
       Dim txtData As String
       Dim iRow, iCol As Double
       Dim accDist_1, accDist_2 As Double
       Dim PtOfData(0 To 2) As Double
       Dim objTxt As AcadText
       Dim bgniCol, bgniRow As Double
       Dim endiCol, endiRow As Double
       Dim lowiRow As Double
       Dim iColNum As Long
       
       Dim PtOfLine(0 To 3) As Double
       Dim accDist_1h, accDist_2h As Double
       Dim txtData_1 As String
       Dim PtOfSprtLine_Dt(0 To 3) As Double
       Dim PtOfSprtLine_Tb(0 To 3) As Double
       

       nCol = frmMenu.sColOfRefP + frmMenu.cmbAccDist - 1      '追加距離の列番号指定
       bgniCol = frmMenu.sColOfRefP - addCnt          '開始列の指定      (先に計算させておく)
       endiCol = frmMenu.eColOfRefP - 1          '最終列番の指定 (          同上        )
       bgniRow = frmMenu.sRowOfRefP + addCnt_Ttl          '開始行の指定      (          同上        )
       endiRow = frmMenu.eRowOfRefP - 1          '最終行番の指定 (          同上        )
         
         For iCol = frmMenu.sColOfRefP To endiCol
         
         
         '<画層設定>   ’列毎(例:測点、距離、追加距離、地盤高、計画高等)の画層設定
         iColNum = Len(CStr(iCol + addCnt))
         
         If iColNum = 2 Then
         preposition = "0"
         Else
         preposition = "00"
         End If

         Set objLayer = AcadDoc.Layers.Item(preposition & (iCol - frmMenu.sColOfRefP + 1 + addCnt))
         AcadDoc.ActiveLayer = objLayer
         
         
         For iRow = bgniRow To endiRow
         
         txtData = Format(Worksheets(wkNameRefP).Cells(iRow, iCol).Text, formatNum)          '縦断テキストデータ
         lowiRow = iRow + 1
         
         If txtData <> "" Then          '空白データが るため。
         
         If iRow = bgniRow Then
         
         accDist_1 = 0
         
         '-----
         Select Case Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value
         
         Case Is = 0
         accDist_1h = Abs(Worksheets(wkNameRefP).Cells(lowiRow, nCol).Value) * 10 ^ 3 / sclOfXAxis  '縦断折れ線用
         
         Case Is > 0
         accDist_1h = Abs(Worksheets(wkNameRefP).Cells(lowiRow, nCol).Value - Worksheets(wkNameRefP).Cells(iRow, nCol).Value) * 10 ^ 3 / sclOfXAxis '縦断折れ線用
         
         Case Is < 0
         accDist_1h = Abs(Worksheets(wkNameRefP).Cells(lowiRow, nCol).Value + Worksheets(wkNameRefP).Cells(iRow, nCol).Value) * 10 ^ 3 / sclOfXAxis '縦断折れ線用
         
         End Select
         '-----
         Else
         
         accDist_1 = Abs(Worksheets(wkNameRefP).Cells(iRow, nCol).Value) * 10 ^ 3 / sclOfXAxis
         '-----
         accDist_1h = Abs(Worksheets(wkNameRefP).Cells(lowiRow, nCol).Value) * 10 ^ 3 / sclOfXAxis  '縦断折れ線用
         '-----
         End If
         
         
         
         Select Case Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value
         
         Case Is = 0
         accDist_2 = 0
         '-----
         accDist_2h = 0      '縦断折れ線用
         '-----
         Case Is > 0
         
         If iRow = bgniRow Then
         accDist_2 = 0
         '-----
         accDist_2h = 0      '縦断折れ線用
         '-----
         Else
         accDist_2 = -Abs(Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value) * 10 ^ 3 / sclOfXAxis
         '-----
         accDist_2h = -Abs(Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value) * 10 ^ 3 / sclOfXAxis
         '-----
         End If
         
         Case Is < 0
         
         If iRow = bgniRow Then
         accDist_2 = 0
         '-----
         accDist_2h = 0  '縦断折れ線用
         '-----
         ElseIf iRow <> bgniRow And Worksheets(wkNameRefP).Cells(iRow, nCol).Value < 0 Then
         accDist_2 = (Abs(Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value) * 10 ^ 3 / sclOfXAxis - accDist_1)
         accDist_1 = 0          'accDist_1に0を代入
         '-----
         accDist_2h = (Abs(Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value) * 10 ^ 3 / sclOfXAxis - accDist_1)
         accDist_1h = 0          'accDist_1に0を代入
         '-----
         Else
         accDist_2 = Abs(Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value) * 10 ^ 3 / sclOfXAxis
         '-----
         accDist_2h = Abs(Worksheets(wkNameRefP).Cells(bgniRow, nCol).Value) * 10 ^ 3 / sclOfXAxis    '縦断折れ線用
         '-----
         End If
         
         End Select
         
         
         PtOfData(0) = xTD(0) + mgnOfInstPt + accDist_1 + accDist_2
         PtOfData(1) = yTD(0) + (heightOfTtlBnd - 1) + (heightOfTtlBnd + lengthOfVSpc) * (iCol - bgniCol) 'heightOfTtlBnd-1は枠からの離れ
         PtOfData(2) = 0
         
         Set objTxt = AcadMs.AddText(txtData, PtOfData, heightOfTxt)
         objTxt.Rotate PtOfData, dtr(90)
         objTxt.HorizontalAlignment = acHorizontalAlignmentRight
         objTxt.VerticalAlignment = acVerticalAlignmentMiddle
         objTxt.TextAlignmentPoint = PtOfData
         objTxt.Color = acGreen
         objTxt.Update
         
         
         If iCol = nCol + 1 Then         '縦断折れ線は、追加距離の次の列を考慮uる。
         
         '<データ帯用>
         PtOfSprtLine_Tb(0) = PtOfData(0)
         PtOfSprtLine_Tb(1) = yTB(2)
         PtOfSprtLine_Tb(2) = PtOfData(0)
         PtOfSprtLine_Tb(3) = yTB(2) + lengthOfVSpc
         
         Set objSprtLine = AcadMs.AddLightWeightPolyline(PtOfSprtLine_Tb)
         copyRctngl = objSprtLine.ArrayRectangular(nRows - 1, nCols, nLevs, distRows, distCols, distLevs)
         
         '<地盤高用>
         PtOfSprtLine_Dt(0) = PtOfData(0)
         PtOfSprtLine_Dt(1) = ySprtX(0)
         PtOfSprtLine_Dt(2) = PtOfData(0)
         PtOfSprtLine_Dt(3) = ySprtX(0) + Worksheets(wkNameRefP).Cells(iRow, iCol).Value * 10 ^ 3 / sclOfYAxis - basicAltitude * 10 ^ 3 / sclOfYAxis
         
         AcadMs.AddLightWeightPolyline (PtOfSprtLine_Dt)
         
         End If
         
         '----------------------
         '縦断折れ線作画
         '----------------------
         If iCol > nCol Then
         
         If iRow <> endiRow Then
         
         txtData_1 = Format(Worksheets(wkNameRefP).Cells(lowiRow, iCol).Text, formatNum)
         
         If txtData <> "" And txtData_1 <> "" Then
         
         PtOfLine(0) = PtOfData(0)
         PtOfLine(1) = ySprtX(0) + Worksheets(wkNameRefP).Cells(iRow, iCol).Value * 10 ^ 3 / sclOfYAxis - basicAltitude * 10 ^ 3 / sclOfYAxis
         PtOfLine(2) = xTD(0) + mgnOfInstPt + accDist_1h + accDist_2h
         PtOfLine(3) = ySprtX(0) + Worksheets(wkNameRefP).Cells(lowiRow, iCol).Value * 10 ^ 3 / sclOfYAxis - basicAltitude * 10 ^ 3 / sclOfYAxis
         
         AcadMs.AddLightWeightPolyline (PtOfLine)
         
         End If
         
         End If
         
         End If
         
         End If
         
         Next iRow
         
         Next iCol





AcadApp.ZoomExtents
Set AcadApp = Nothing

Unload frmMenu

End Sub


'--------------------------------------------
'       角度をラジアンに変兜
'--------------------------------------------
Public Function dtr(dd As Variant) As Double

   Dim pi As Double
       
       pi = Application.WorksheetFunction.pi
       dtr = pi * (dd / 180#)
       
End Function






I can send the excel file itself if you wanted to.

Regards

Answer
As far as I can see the excel side of the macro should work fine in the later version, however the autocad bit is a mystery to me - I have no knowledge of autocad - for VBA to control an external program it needs to use the appropriate terms FOR that program - you would therefore need someone who knows autocad ideally with VBA knowledge as well.
About Excel
This topic answers questions related to Microsoft Excel spreadsheet (or workbook) stand-alone or Mircrosoft Office Excel including Excel 2003, Excel 2007, Office 2000, and Office XP. You can get Excel help on Excel formulas(or functions), Excell macros, charting in Excel, advanced features, and the general use of Excel. This does not provide a general Excel tutorial nor the basics of using a spreadsheet. It provides specific answers to using Microsoft Excel only. If you do not see your Excel question answered in this area then please ask an Excel question here

Excel

All Answers


Answers by Expert:


Ask Experts

Volunteer


Aidan Heritage

Expertise

I have provided first hand support since `95 for Microsoft Office majoring in Word and Excel - support for all versions from 2 onwards. I'm based in the UK, so please allow for time differences when asking me questions from other parts of the world!

Experience

My background is in the insurance industry and call centre areas, but have been called upon to provide many varied solutions.

Education/Credentials
I'm educated to UK A level standard, but as I left school some 30 years ago that is rather irrelevent - university of life has provided more of a background!

©2016 About.com. All rights reserved.