EXCEL VBAを使ってFEMAP プロパティのI型ビームを作成する方法

Sub CreatIBeam

  'Femap model オブジェクトの作成
  Dim f As Object
  Set f = GetObject(,"femap.model")
  
  'プロパティオブジェクトの作成
  Dim pr As Object
  Set pr = f.feProp
  
  'リターンコードの格納先
  Dim rc As Long

  '形状の入力（I型断面の場合)
  Dim shape(5) As Double
  shape(0) = 400 '高さの入力。この場合、高さ400となる。
  shape(1) = 400 '上面の幅。この場合、幅400となる。
  shape(2) = 400 '下面の幅。この場合、幅400となる。
  shape(3) = 16  '上面の板厚。この場合、16となる。
  shape(4) = 16  '下面の板厚。この場合、16となる。
  shape(5) = 12  '中央縦ウェブの板厚。この場合12となる。
  
  'オリエンテーション方向の設定。0:右, 1:上, 2:左, 3:下
  Dim orient As Long
  orient = 0
  
  pr.title = "400X400X12/16 I"  'タイトルの入力。この場合、「400X400X12/16 I」となる。
  pr.matlID = 1  'マテリアルIDの入力。この場合1となる。
  pr.Type = 5    'タイプの入力。ビームの場合5にする。
  
  'プロパティの作成
  rc = pr.ComputeStdShape(9, shape, orient, 0, True, True, False) '引数は順に形状ID, 断面定義パラメータ、向き、断面評価方法、せん断中心オフセット計算、ねじれ定数計算、応力取り出し位置
  pr.Put(1)  'プロパティID １ にここで作成したプロパティを登録する。
  
  'オブジェクト開放
  Set pr = Nothing
  Set f = Nothing
  
  if rc = 0 then
    MsgBox "プロパティ作成に失敗しました"
  else
    MsgBox "プロパティを作成しました"
  End If
  
End Sub

Sub CreatIBeam

  'Femap model オブジェクトの作成
  Dim f As Object
  Set f = GetObject(,"femap.model")
  
  'プロパティオブジェクトの作成
  Dim pr As Object
  Set pr = f.feProp
  
  'リターンコードの格納先
  Dim rc As Long

  '形状の入力（I型断面の場合)
  Dim shape(5) As Double
  shape(0) = Cells(2,4) '高さの入力
  shape(1) = Cells(2,5) '上面の幅。
  shape(2) = Cells(2,6) '下面の幅。
  shape(3) = Cells(2,7)  '上面の板厚。
  shape(4) = Cells(2,8)  '下面の板厚。
  shape(5) = Cells(2,9)  '中央縦ウェブの板厚。
  
  'オリエンテーション方向の設定。0:右, 1:上, 2:左, 3:下
  Dim orient As Long
  orient = Cells(2,10)
  
  pr.title = Cells(2,3)  'タイトルの入力。
  pr.matlID = Cells(2,2) 'マテリアルIDの入力。
  pr.Type = 5            'タイプの入力。ビームの場合5にする。
  
  'プロパティの作成
  rc = pr.ComputeStdShape(9, shape, orient, 0, True, True, False) '引数は順に形状ID, 断面定義パラメータ、向き、断面評価方法、せん断中心オフセット計算、ねじれ定数計算、応力取り出し位置
  pr.Put(Cells(2,1))  'ここで指定した番号IDに作成したプロパティを登録する。
  
  'オブジェクト開放
  Set pr = Nothing
  Set f = Nothing
  
  if rc = 0 then
    MsgBox "プロパティ作成に失敗しました"
  else
    MsgBox "プロパティを作成しました"
  End If
  
  End Sub

Sub GetBeamProperty()

  On Error GoTo OUT1
  'FEMAP model オブジェクトの生成
  Dim f As Object
  Set f = GetObject(,"femap.model")
  
  On Error GoTo OUT2
  'プロパティオブジェクトの生成
  Dim pr As Object
  Set pr = f.feProp
  
  Dim rc As Long 'リターンコード
  
  pr.Get(Int(Cells(1,2))) 'セルB1で入力したプロパティIDの取得
  
  Cells(2,2) = pr.matlID  'マテリアルIDの取得
  Cells(3,2) = pr.title   'タイトルの取得
  Cells(4,2) = pr.Type    'タイプの取得。ビーム要素なら5になる。
 
  'もし取得したプロパティがビームなら、次の項目も取得する
  If pr.Type = 5 Then
    Cells(5,2) = pr.pval(40)   '一般断面の高さ
    Cells(6,2) = pr.pval(41)   '一般断面の上板幅    
    Cells(7,2) = pr.pval(42)   '一般断面の下板幅  
    Cells(8,2) = pr.pval(43)   '一般断面の上板厚  
    Cells(9,2) = pr.pval(44)   '一般断面の下板厚  
    Cells(10,2) = pr.pval(45)  '一般断面の中央部板厚  
    Cells(11,2) = pr.pval(0)   '端点Aの断面積
    Cells(12,2) = pr.pval(5)   '端点AのY有効断面積 
    Cells(13,2) = pr.pval(6)   '端点AのZ有効断面積
    Cells(14,2) = pr.pval(1)   '端点AのI1
    Cells(15,2) = pr.pval(2)   '端点AのI2    
    Cells(16,2) = pr.pval(16)  '端点Aの中性軸オフセットY
    Cells(17,2) = pr.pval(17)  '端点Aの中性軸オフセットZ
  Else
    MsgBox "このプロパティ " & Cells(1,2) & " はビームではありません。"
  End If  
    
  'オブジェクト開放
  Set pr = Nothing
  Set f = Nothing
  
  Exit Sub
OUT1:
  MsgBox "FEMAPを起動してください"
  Exit Sub
OUT2:
  MsgBox "不明なエラー"
End Sub