admin menu ≫  image  writes  admin
スポンサーサイト 
--.--.--.-- 
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
エクセルVBA(その2) 
2009.02.12.Thu 
BASICで書くのは、NECのN88以来なので結構手間取ったけど
2/7に書き込んだプログラムとは全く違う考え方で最初から作り直して
取りあえずここまで出来たぞっと!!(^^v・・・CADデータに変換できないのが残念です!!(^^;
BoxCulvert.jpg
エクセルVBA(その2)・・・見やすくなったかな?(^^;

Sub Macro100( )
'「エクセルのオートシェイプでボックスカルバートの配筋図を書いてみよう!!」
'「単精度だけど漫画くらいなら書けるでしょ!?」
' 2009/02/05 取り敢えずオートシェイプで書けるか試してみた。version1
' 2009/02/06 何となく書けそうな気がするし、続けてみるか・・・
' 2009/02/07 結構苦戦!!If文が長すぎ!!後から見たら判らなくなるし、
'         最初から見直してみることに(^^;
' 2009/02/09 version2!!に書き換え開始。
'         シートの計算機能を使って予め図形座標を設定することにしたので
'         最初から書き換えすることに(^^;
'        サブルーチンのDo?Loop文の使い方が間違ってるし(^^;
'        コメント文も満載にしてみるか!?
' 2009/02/10 version2で何となく行けそうな気がするぅ?!!
'         けど、コメント書くのはやっぱ大変だ(^^;挫折
' 2009/02/11 組立方法?の平面図はほぼ完成かな??

'BASIC言語は、変数の型宣言をしなくてもいきなりプログラミングできる手軽さがあるけど
'変数の型を事前に記述(宣言)する癖をつけておくとプログラミングミスが少なくなる。
Dim Kumi As Integer '組立方法の変数
Dim mydocument, Datasheet '作業シートとデータシートの名称を代入する変数

  Kumi = 1 'プログラミング中なので取り敢えず組立方法?に仮定しておく(^^

'オートシェイプ用の作業シートとデータシートの指定
  
  'If?Else?End If文でオートシェイプ作業シートを選択
  If Kumi = 1 Then              '組立方法?の場合
    Sheets("配筋図?").Select        '「配筋図?」シートをアクティブシートで表示
    Set mydocument = Worksheets("配筋図?") 'myDocumentを「配筋図?」に設定
  Else                    '組み立て方法?以外・・・?の場合
    Sheets("配筋図?").Select        '「配筋図?」シートをアクティブシートで表示
    Set mydocument = Worksheets("配筋図?") 'myDocumentを「配筋図?」に設定
  End If
  
  Set Datasheet = Worksheets("作図データ") 'データシートは「作図データ」シートとする

'作業シート内の図形を全削除
  
  mydocument.Shapes.SelectAll     '作業シートにあるオートシェイプを全て選択して
  Selection.Cut            '全削除
  mydocument.Range("C4").Value = ""  'おまじない(^^

'For?Next文の引数の設定とボックスカルバートの基本データ
Dim i, j, k, n, m As Integer 'For?Next文などで使う引数の宣言
Dim data(20) As Single '読み込み用データ
'★20個の配列を宣言したつもりなのにdata(0)?data(20)番まで21個確保された??
'普通ならdata(0)?data(19)で20個になるのに(^^;・・・BASICの仕様なのかな??
Dim B, H, LL As Single       'ボックスカルバートの基本データ
Dim t1, t2, t3, C1, C2 As Single  'ボックスカルバートの基本データ
Dim d, R, sl, W2, p As Single    'ボックスカルバートの基本データ
  
  '基本データの読み込み
  'For?Next文を使ってデータシートの"C"列の3?16行目までのデータをdata(3)?data(16)まで順番に読み込む
  For i = 3 To 16 '行番号3?16までインクリメントする
    data(i) = Datasheet.Range("C" & i).Value
  Next i 'iをインクリメント
  
  '読み込んだdata(3)?data(16)を識別出来るようにボックスカルバートの基本データ変数に代入する
  'マクロで使わないデータもあるけど取り合えあえず設定しておく
  B = data(3)   '内幅をBに代入
  H = data(4)   '内高をHに代入
  L = data(5)   '長さをLに代入
  t1 = data(6)  '頂版の厚さt1にを代入
  t2 = data(7)  '底版の厚さt2にを代入
  t3 = data(8)  '側壁の厚さt3にを代入
  C1 = data(9)  '頂版側のハンチ寸法C1にを代入
  C2 = data(10)  '底版側のハンチ寸法C2にを代入
  d = data(11)  '鉄筋の芯被りをdに代入
  R = data(12)  '外側鉄筋偶角部の曲げ半径=10×鉄筋経をRに代入
  sl = data(13)  '重ね長さをslに代入
  n = data(14)  '主筋の本数をnに代入
  W2 = data(15)  '外側の主筋本数をW2代入
  p = data(16)  '主筋のピッチをpに代入

'セルのカラム位置をカウントで数えられるように設定
Dim Sell, Column(26) As String     '取り敢えずカラム"A"?"Z"までの26列を文字属性の配列で宣言しておく
Dim Column1, Column2, Row As Integer  '行は読み込みの都度インクリメントするので1個だけ宣言

  Column(1) = "A" '文字データ配列のColumn(1)に文字Aを設定
  Column(2) = "B" '文字データ配列のColumn(2)に文字Bを設定
  Column(3) = "C" '3
  Column(4) = "D" '4
  Column(5) = "E" '5
  Column(6) = "F" '6
  Column(7) = "G" '7
  Column(8) = "H" '8
  Column(9) = "I" '9
  Column(10) = "J" '10
  Column(11) = "K" '11
  Column(12) = "L" '12
  Column(13) = "M" '13
  Column(14) = "N" '14
  
'平面図座標の読み込みと平面図の作図
Dim stx, sty, edx, edy, ctx As Single  '図形の右上座標、左下座標、中心座標データ変数
Dim x(10), y(10) As Single       '取りあえず作図用の座標データ変数を10個宣言しておく
  
  'データシートから座標データを読み込んで作図するサブルーチン
  'Sub AutoShape(myDocument, Datasheet, Column1, Column2, Row, Plus_Row, k, EndNum, increment_n, pic, x, y)
  '↓サブルーチンを実行
  Column1 = "B" '引数に直接設定しても良いが、取りあえずcolumn1に文字Bを代入
  Column2 = "C" '同様にcolumn1に文字Cを代入
  Row = 22 'データシートの"B"列と"C"列の22行目から5個のデータを読み込んで連続線(引数increment_Num=1)で四角形を書く
  Call AutoShape(mydocument, Datasheet, Column1, Column2, Row, 5, 4, 1, 0, 0.75, x, y) 'サブルーチンの呼出実行
  
  '変数xとyは、以降の作図処理でも使う為、取りあえず上記のサブルーチンで読み込んできたデータを別の変数に代入しておく
  stx = x(1) 'サブルーチンで読み込んできたx(1)を変数stxに代入
  sty = y(1) '同じくy(1)を変数styに代入   1┌─────┐2
  edx = x(3) '同じくx(3)を変数edxに代入    │        │
  edy = y(3) '同じくy(3)を変数edyに代入    │   ・5   │
  ctx = x(5) '同じくx(5)を変数ctxに代入    │      │
  cty = y(5) '同じくy(5)を変数ctyに代入   4└─────┘3
  
'1行コメントはやっぱ大変なんでここまでぇ??(^^;//~~~~~~~
  
'平面図:主筋座標データの読み込みと作図
Dim Haunch, HL As Single 'ハンチ筋の有無とハンチ筋の長さ

  'ハンチ筋長さの読み込み
  HL = Datasheet.Range("P31").Value
  
  Row = 31 '31行目から主筋座標データの読み込んで作図を開始する
  
  m = 0 'ハンチ筋の数をカウントする
    
  For i = 1 To n
    k = 2 'B?N列までの主筋座標データの読み込み
    For j = 1 To 6
      x(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1 'kをインクリメント
      y(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1 'kをインクリメント
    Next j
    Haunch = Datasheet.Range(Column(k) & Row).Value 'ハンチ筋の有無の指定の確認
    
    '主筋の作図
    Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 1.25)
    If Kumi = 2 Then
      Call StraightLine(mydocument, x(3), y(3), x(4), y(4), 1.25)
    End If
    Call StraightLine(mydocument, x(5), y(5), x(6), y(6), 1.25)
    
    '寸法線データをデータシートに書き込み
    If i = 1 Then '1本目の寸法線データの書き込み
      If Kumi = 1 Then
        Datasheet.Range("C70").Value = y(1)
        Datasheet.Range("G70").Value = y(6)
      Else
      '★ここに組立方法?の処理を記述する
      End If
    ElseIf i = n Then 'n本目の寸法線データの書き込み
      If Kumi = 1 Then
        Datasheet.Range("C71").Value = y(1)
        Datasheet.Range("G71").Value = y(6)
      Else
      '★ここに組立方法?の処理を記述する
      End If
    End If
    
    'ハンチ筋の作図
    If Haunch <> 0 Then
      m = m + 1
      If Haunch = 1 Then
        Call HaunchLine(mydocument, x(1), y(1) - 2, x(1) + HL, y(2) - 2, 1#)
        Call HaunchLine(mydocument, x(6), y(1) - 2, x(6) - HL, y(2) - 2, 1#)
      Else
        Call HaunchLine(mydocument, x(1), y(6) + 2, x(1) + HL, y(6) + 2, 1#)
        Call HaunchLine(mydocument, x(6), y(6) + 2, x(6) - HL, y(6) + 2, 1#)
      End If
    Else
    '
    End If
    
    Row = Row + 1 '行をインクリメント
  
  Next

'平面図の右側寸法線
  Row = 69
  For i = 0 To 5
    k = 6 'F?I列までの寸法線データの読み込みと書き込み
    For j = 1 To 2
      x(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
    Next j
    Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 0.75)
  Next

'平面図の右側寸法線の矢印の書き込み
Dim str As String
  
  Row = 78
  For i = 0 To 5
    k = 9 'I?K列までの矢印データの読み込みと書き込み
    x(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    y(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    str = Datasheet.Range(Column(k) & Row + i).Value
    Call Arrow(mydocument, x(1), y(1), str)
  Next
  
'平面図右側寸法の書き込み
  Row = 78
  For i = 0 To 3
    k = 12 'L?N列までの寸法データの読み込みと書き込み
    str = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    x(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    y(1) = Datasheet.Range(Column(k) & Row + i).Value
    Call Text(mydocument, x(1), y(1), 100, 100, "V", str)
  Next

'組立方法?の平面図の左側寸法線

  If Kumi = 1 Then '組立方法?は左側にも寸法線を書き込む
  
    '寸法線
    Row = 69
    For i = 0 To 4
      k = 2 'B?E列までの寸法線データの読み込みと書き込み
      For j = 1 To 2
        x(j) = Datasheet.Range(Column(k) & Row + i).Value
        k = k + 1 'kをインクリメント
        y(j) = Datasheet.Range(Column(k) & Row + i).Value
        k = k + 1 'kをインクリメント
      Next j
      Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 0.75)
    Next

    '矢印の書き込み
    Row = 78
    For i = 0 To 3
      k = 2 'B?D列までの矢印データの読み込みと書き込み
      x(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      str = Datasheet.Range(Column(k) & Row + i).Value
      Call Arrow(mydocument, x(1), y(1), str)
    Next
  
    '寸法の書き込み
    Row = 78
    For i = 0 To 2
      k = 5 'L?N列までの寸法データの読み込みと書き込み
      str = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      x(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(1) = Datasheet.Range(Column(k) & Row + i).Value
      Call Text(mydocument, x(1), y(1), 100, 100, "V", str)
    Next
  End If

'平面図の配力筋のピッチの計算
Dim hn As Integer
Dim Bd, Px, Hp, Hpp, Pitch As Single

  hn = Int(Datasheet.Range("C53").Value / 2) '配力筋の本数1/2
  
  j = 6 'データの列番号"F"
  Row = 56
  Px = ctx + 15#
  Datasheet.Range(Column(j) & Row).Value = Px '1本目のセンターからのピッチ
  Row = Row + 1
  
  For i = 2 To 10 'センターから2本目以降のピッチを0mmに仮設定
    If i <= hn Then
      Px = Px + 30#
      Datasheet.Range(Column(j) & Row).Value = Px
    Else
      Datasheet.Range(Column(j) & Row).Value = 0#
    End If
    Row = Row + 1
  Next i
  
'ピッチの計算とデータ登録

  Row = 56
  Hp = 30# '端部のピッチ
  Hpp = 30# ' 端部から2本目のピッチ
  If B <= 140 Then '内幅1400mm以下の配置方法
    Bd = B - 3 '内幅?30mmの範囲に収める
    If hn = 2 Then '片側2本配置する場合
      Px = Datasheet.Range(Column(j) & Row).Value
      Hp = (Bd - 30#) / 2
      If 30 < Hp Then
        Hp = 30#
      End If
      Px = Px + Hp
      Datasheet.Range(Column(j) & Row + 1).Value = Px
    Else '片側3本以上配置する場合の端部のピッチ
      Hp = (Bd - 30# * 3) / 2
      Px = Datasheet.Range(Column(j) & Row + hn - 2).Value
      Datasheet.Range(Column(j) & Row + hn - 1).Value = Px + Hp
    End If
  Else '内幅1400mmを超える場合の端部のピッチ
    Bd = B + d * 2 - 3# '内幅+鉄筋被り?30mmの範囲に収める
    Hp = (Bd - 30 * (hn * 2 - 3)) / 2 '端部のピッチ
    If Hp < 15 Then '端部のピッチが150mm以下になった場合、端部2本で調整する
      Hp = (Hp + 30#) / 2#
      Hpp = Hp
      Px = Datasheet.Range(Column(j) & Row + hn - 3).Value
      Datasheet.Range(Column(j) & Row + hn - 2).Value = Px + Hpp '端部から2本目
    End If
    Px = Datasheet.Range(Column(j) & Row + hn - 2).Value
    Datasheet.Range(Column(j) & Row + hn - 1).Value = Px + Hp '端部
  End If

'配力筋の作図と寸法線データの書き込み
Dim Row1, Row2 As Integer

  '寸法線データの初期化
  For i = 86 To 92
    Datasheet.Range("B" & i).Value = 0#
  Next
  Row1 = 88 '寸法線データの書き込み行
  Row2 = 89
  
  Row = 56 '56行目から座標データを読み込み開始
  For i = 1 To hn
    k = 2
    For j = 1 To 4 'B列?J列までのデータを読み込み
      x(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1
      y(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1
    Next
    
    Pitch = Datasheet.Range(Column(k) & Row).Value '登録データのピッチの読み込み
    
    '配力筋の作図
    Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 1.25) 'センターから左側の作図
    Call StraightLine(mydocument, x(3), y(3), x(4), y(4), 1.25) 'センターから右側の作図
    
    '引出し線と寸法線データの書き込み
    If 1 < i And Pitch <> 30# Then
      x(2) = x(1) + Pitch
      x(3) = x(4) - Pitch
      Datasheet.Range("B" & Row1).Value = x(2)  '左側寸法線x座標の書き込み
      Datasheet.Range("B" & Row2).Value = x(3)  '右側寸法線x座標の書き込み
      Row1 = Row1 - 1               'Row1の書き込み行をデクリメント
      Row2 = Row2 + 1               'Row2の書き込み行をインクリメント
    End If
    If i = hn Then '両端部の引出し線と寸法線データの書き込み
      Datasheet.Range("B86").Value = x(1) '1
      Datasheet.Range("B91").Value = x(4) '6
      Datasheet.Range("F86").Value = Pitch '端部ピッチ
      If Pitch = 30# Then
        Datasheet.Range("G86").Value = 0 '調整なし
      Else
        If Hpp = 30# Then '端部から2本目のピッチが300mmの場合
          Datasheet.Range("G86").Value = 1 '調整本数
        Else
          Datasheet.Range("G86").Value = 2 '調整本数
        End If
      End If
    End If
    Row = Row + 1 '行をインクリメント
  Next i
  
  If Pitch < 15 Then 'ピッチが150mm未満の場合の矢印は→||←
    Datasheet.Range("B92") = x(1) - 10
    Datasheet.Range("D92") = x(4) + 10
  Else
    Datasheet.Range("B92") = x(1)
    Datasheet.Range("D92") = x(4)
  End If
  
'配力筋の引出し線と寸法線の書き込み
  Row = 86
  For i = 0 To 6
    k = 2
    For j = 1 To 2
      x(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
    Next j
    If x(1) <> 0# Then
      Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 0.75)
    End If
  Next
  
'矢印の向き判定と書き込み
  
  Row = 86
  y(1) = Datasheet.Range("C92").Value '矢印を書き込むy座標
  
  If Pitch < 15 Then '端部ピッチが150mm以下の場合
    For i = 0 To 5
      k = 2
      x(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      If x(1) <> 0# Then
        If i = 0 Then
          Call Arrow(mydocument, x(1), y(1), "Right")
        ElseIf i = 5 Then
          Call Arrow(mydocument, x(1), y(1), "Left")
        Else
          If ctx < x(1) Then
            Call Arrow(mydocument, x(1), y(1), "Right")
          Else
            Call Arrow(mydocument, x(1), y(1), "Left")
          End If
        End If
      End If
    Next
  Else
    For i = 0 To 5
      k = 2
      x(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      If x(1) <> 0# Then
        If i = 0 Then
          Call Arrow(mydocument, x(1), y(1), "Left")
        ElseIf i = 5 Then
          Call Arrow(mydocument, x(1), y(1), "Right")
        Else
          Call Arrow(mydocument, x(1), y(1), "Right")
          Call Arrow(mydocument, x(1), y(1), "Left")
        End If
      End If
    Next
  End If
  
'ピッチの書き込み
 
  '座標の読み込み
  k = 2 'B
  x(1) = Datasheet.Range(Column(k) & 86).Value + Hp / 2 - 9 '寸法を書き込む左端のx座標
  x(6) = Datasheet.Range(Column(k) & 91).Value - Hp / 2 - 9 '寸法を書き込む右端のx座標
  k = k + 1 'C
  y(1) = Datasheet.Range(Column(k) & 92).Value - 14        '寸法を書き込むy座標
  Call Text(mydocument, x(1), y(1), 100, 100, "H", Int(Hp * 10))
  Call Text(mydocument, x(6), y(1), 100, 100, "H", Int(Hp * 10))

  If Hpp <> 30# Then
    Call Text(mydocument, x(1) + Hp, y(1), 100, 100, "H", Int(Hpp * 10))
    Call Text(mydocument, x(6) - Hp, y(1), 100, 100, "H", Int(Hpp * 10))
  End If
  
  If hn = 2 And Hp <> 30# Then '配力筋の本数が片側2本で端部のピッチが300mmでない場合
    Call Text(mydocument, ctx - 10, y(1), 100, 100, "H", "300")
  Else
    If hn = 2 Then '配力筋の本数が片側2本で端部のピッチが300mmで3@300=900と表示する
      i = 3
    Else '配力筋の本数が片側2本以上の場合
      i = hn * 2 - 3
      If Hpp <> 30 Then '端部2本分のピッチが300mm以下の場合
      i = i - 2
      End If
    End If
    Call Text(mydocument, ctx - 25, y(1), 100, 100, "H", i & "@300=" & i * 300)
  End If
  
'断面図/////////////////////////////////////////////////////////

'外側断面の座標の取得と作図
  Column1 = "B"
  Column2 = "C"
  Row = 96
  Call AutoShape(mydocument, Datasheet, Column1, Column2, Row, 4, 4, 1, 0, 0.75, x, y)

'内側断面の座標の取得と作図
  
  Row = 103
  Call AutoShape(mydocument, Datasheet, Column1, Column2, Row, 8, 8, 1, 0, 0.75, x, y)
  
'内側鉄筋の座標の取得と作図
  
  Row = 113
  Call AutoShape(mydocument, Datasheet, Column1, Column2, Row, 8, 8, 8, 1, 1.25, x, y)

'外側鉄筋の座標の取得と作図
  
  Row = 123
  Call AutoShape(mydocument, Datasheet, Column1, Column2, Row, 8, 8, 8, 1, 1.25, x, y)
  
'ハンチ筋の座標の取得と作図
  
  Row = 133
  Call AutoShape(mydocument, Datasheet, Column1, Column2, Row, 8, 8, 8, 1, 1.25, x, y)

'偶角部の折曲げ
  
  Row = 144
  Call Mage(mydocument, Datasheet, Row, R)

'右側壁側寸法線の書き込み
  Row = 150
  For i = 0 To 11
    k = 2
    For j = 1 To 2
      x(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
    Next j
    Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 0.75)
  Next

'右側壁側寸法線の矢印の書き込み
  Row = 165
  For i = 0 To 15
    k = 2
    x(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    y(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    str = Datasheet.Range(Column(k) & Row + i).Value
    Call Arrow(mydocument, x(1), y(1), str)
  Next

'右側壁側寸法の書き込み
  Row = 165
  For i = 0 To 15
    k = 6
    data(0) = Datasheet.Range(Column(k) & Row + i).Value
    If data(0) <> 0 Then
      k = k + 1 'kをインクリメント
      x(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(1) = Datasheet.Range(Column(k) & Row + i).Value
      Call Text(mydocument, x(1), y(1), 100, 100, "V", data(0))
    End If
  Next

'底版側寸法線の書き込み
  Row = 184
  For i = 0 To 11
    k = 2
    For j = 1 To 2
      x(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(j) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
    Next j
    Call StraightLine(mydocument, x(1), y(1), x(2), y(2), 0.75)
  Next

'底版側寸法線の矢印の書き込み
  Row = 199
  For i = 0 To 15
    k = 2
    x(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    y(1) = Datasheet.Range(Column(k) & Row + i).Value
    k = k + 1 'kをインクリメント
    str = Datasheet.Range(Column(k) & Row + i).Value
    Call Arrow(mydocument, x(1), y(1), str)
  Next

'底版側寸法の書き込み
  Row = 199
  For i = 0 To 15
    k = 6
    data(0) = Datasheet.Range(Column(k) & Row + i).Value
    If data(0) <> 0 Then
      k = k + 1 'kをインクリメント
      x(1) = Datasheet.Range(Column(k) & Row + i).Value
      k = k + 1 'kをインクリメント
      y(1) = Datasheet.Range(Column(k) & Row + i).Value
      Call Text(mydocument, x(1), y(1), 100, 100, "H", data(0))
    End If
    If i = 7 Then
      Call Text(mydocument, x(1) + 20, y(1) + 10, 100, 100, "H", "芯被り")
    End If
  Next

'頂底版の配力筋x座標の書き込み
  
  'データの初期化
  Row1 = 218
  Row2 = 231
  For i = 1 To 10
    Datasheet.Range("B" & Row1).Value = 0#
    Datasheet.Range("B" & Row2).Value = 0#
    Row1 = Row1 + 1
    Row2 = Row2 + 1
  Next

  '図形中心x座標からのピッチデータを読み込んで中心座標からの距離を計算し座標データをシートに書き込む
  Column(0) = "J": Row = 56
  Column1 = "B": Row1 = 218
  Column2 = "B": Row2 = 231
  x(2) = 0
  For i = 1 To hn
    x(1) = Datasheet.Range(Column(0) & Row).Value
    x(2) = x(2) + x(1)
    Datasheet.Range(Column1 & Row1).Value = ctx - x(2)
    Datasheet.Range(Column2 & Row2).Value = ctx + x(2)
    Row = Row + 1
    Row1 = Row1 + 1
    Row2 = Row2 + 1
  Next

Dim out_n, in_n As Integer '外側と内側の本数
  
  out_n = Datasheet.Range("J218").Value / 2
  in_n = Datasheet.Range("K218").Value / 2
  
  Row = 218
  For i = 1 To out_n
    k = 2 'B?I
    For j = 1 To 4
      x(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1
      y(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1
    Next
    Call CircleLine(mydocument, 0, 360, 0.75, x(1), y(1))
    Call CircleLine(mydocument, 0, 360, 0.75, x(4), y(4))
    If i <= in_n Then '内側
      Call CircleLine(mydocument, 0, 360, 0.75, x(2), y(2))
      Call CircleLine(mydocument, 0, 360, 0.75, x(3), y(3))
    End If
    Row = Row + 1
  Next
 
  Row = 231
  For i = 1 To out_n
    k = 2 'B?I
    For j = 1 To 4
      x(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1
      y(j) = Datasheet.Range(Column(k) & Row).Value
      k = k + 1
    Next
    Call CircleLine(mydocument, 0, 360, 0.75, x(1), y(1))
    Call CircleLine(mydocument, 0, 360, 0.75, x(4), y(4))
    If i <= in_n Then '内側
      Call CircleLine(mydocument, 0, 360, 0.75, x(2), y(2))
      Call CircleLine(mydocument, 0, 360, 0.75, x(3), y(3))
    End If
    Row = Row + 1
  Next

'オートシェイプ図形のプロパティの変更
  mydocument.Shapes.SelectAll   '全オートシェイプ図形を取得
  With Selection
    .Placement = xlFreeFloating '「セルに合わせて移動やサイズを変更しない」に設定
    .PrintObject = True
  End With

'ハンチ筋の数の判定
  If m <> n / 2 Then
    mydocument.Range("C4").Value = "ハンチ筋の数が一致しません!!"
    Range("C4").Select
  Else
    Range("A1").Select
  End If

End Sub
???????????????????????????????????????
Sub AutoShape(mydocument, Datasheet, Column1, Column2, Row, PlusRow, k, EndNum, increment_n, pic, x, y)
'オートシェイプで線を書く
Dim Shell As String
  For i = 1 To PlusRow
    Sell = Column1 & Row: x(i) = Datasheet.Range(Sell).Value
    Sell = Column2 & Row: y(i) = Datasheet.Range(Sell).Value
    Row = Row + 1
  Next
  
  i = 1
  Do '連続線を書くにはFor?Next文よりDo?Loop文の方がコードが簡潔になるんです(^^
    j = i Mod k + 1 '除算を使うのがミソ(^^
    Call StraightLine(mydocument, x(i), y(i), x(j), y(j), pic)
    If j = EndNum Then Exit Do '無限ループにならないように「おまじない?」
    i = j + increment_n
  Loop
End Sub
???????????????????????????????????????
Sub Mage(mydocument, Datasheet, Row, R)
'偶角部の折曲げ
Dim i As Integer
Dim cx(5), cy(5) As Single
Dim StA, EdA As Single

  For i = 1 To 4
    Sell = "B" & Row: cx(i) = Datasheet.Range(Sell).Value
    Sell = "C" & Row: cy(i) = Datasheet.Range(Sell).Value
    Row = Row + 1
  Next
  
  StA = 0
  EdA = 90
  For i = 1 To 4
    Call CircleLine(mydocument, StA, EdA, R, cx(i), cy(i))
    StA = EdA
    EdA = EdA + 90
  Next

End Sub
???????????????????????????????????????
Sub CircleLine(mydocument, StA, EdA, R, x, y)
'直線で円を書いてみる(^^
Dim x1, x2 As Single
Dim y1, y2 As Single
Dim StartA, EndA As Single
Dim Pai As Double '取り敢えず倍精度でいいかな?
  Pai = 3.14159265358979 / 180
  StartA = StA
  EndA = EdA
  j = 15
  EndA = EndA - j
  For i = StartA To EndA Step j
    x1 = x + R * Sin(i * Pai)
    y1 = y + R * Cos(i * Pai) * -1
    x2 = x + R * Sin((i + j) * Pai)
    y2 = y + R * Cos((i + j) * Pai) * -1
    Call StraightLine(mydocument, x1, y1, x2, y2, 1.25)
  Next
End Sub
???????????????????????????????????????
Sub StraightLine(mydocument, x1, y1, x2, y2, pic)
'直線を書く
  With mydocument.Shapes.AddLine(x1, y1, x2, y2).Line
    .Weight = pic
    .DashStyle = msoLineSolid
    .ForeColor.RGB = RGB(0, 0, 0)
    .EndArrowheadStyle = msoArrowheadNone
  End With
End Sub
???????????????????????????????????????
Sub HaunchLine(mydocument, x1, y1, x2, y2, pic)
'平面図と側面図のハンチ筋の作図
  With mydocument.Shapes.AddLine(x1, y1, x2, y2).Line
    .Weight = pic
    .DashStyle = msoLineDash
    .ForeColor.RGB = RGB(0, 0, 0)
    .EndArrowheadStyle = msoArrowheadNone
  End With
End Sub
???????????????????????????????????????
Sub Arrow(mydocument, x, y, str)
'矢印を書く(^^
Dim x1, x2 As Single
Dim y1, y2 As Single
  If str = "Top" Then
    x1 = x + 2
    y1 = y + 4
    x2 = x - 2
    y2 = y1
  ElseIf str = "Down" Then
    x1 = x + 2
    y1 = y - 4
    x2 = x - 2
    y2 = y1
  ElseIf str = "Left" Then
    x1 = x + 4
    y1 = y - 2
    x2 = x1
    y2 = y + 2
  Else
    x1 = x - 4
    y1 = y - 2
    x2 = x1
    y2 = y + 2
  End If
  Call StraightLine(mydocument, x, y, x1, y1, 0.75)
  Call StraightLine(mydocument, x, y, x2, y2, 0.75)
End Sub
???????????????????????????????????????
Sub Text(mydocument, x, y, width, height, str1, str2)
'文字の書き込み
Dim MyShape As Shape
  If width = 0 Then
    width = 100
  End If
  If height = 0 Then
    height = 100
  End If
  
  If str1 = "H" Then
    mydocument.Shapes.AddLabel(msoTextOrientationHorizontal, x, y, width, height).Select
    Selection.ShapeRange(1).TextFrame.AutoSize = msoTrue
    Selection.Characters.Text = str2
  Else
    mydocument.Shapes.AddLabel(msoTextOrientationUpward, x, y, width, height).Select
    Selection.ShapeRange(1).TextFrame.AutoSize = msoTrue
    Selection.Characters.Text = str2
  End If
  With Selection.Characters(Start:=1, Length:=20).Font
    .Name = "MS ゴシック"
  End With
End Sub
???????????????????????????????????????
Sub ShapesCut()
'図形切取り
  ActiveSheet.Shapes.SelectAll
  With Selection
    .Placement = xlMoveAndSize
    .PrintObject = True
  End With
  Selection.Cut
End Sub
???????????????????????????????????????
Sub Macro1()
  Worksheets("作図データ").Range("C1").Value = 1 '「作図データ」シートのセル"C1"に組立方法の「1」を書き込み設定
  Call Macro100  'Macro100の呼び出し実行
  Worksheets("組立方法?数量表").PrintPreview   '「組立方法?数量表」シートの印刷プレビュー
  Sheets("データ").Select  '「データ」シートをアクティブシートとして表示
End Sub
????????????????????????????????????????
Sub Macro2()
  'Worksheets("作図データ").Range("C1").Value = 2 '「作図データ」シートのセル"C1"に組立方法の「2」を書き込み設定
  'Call Macro100  'Macro100の呼び出し実行
  Worksheets("組立方法?数量表").PrintPreview  '「組立方法?数量表」シートの印刷プレビュー
  Sheets("データ").Select  '「データ」シートをアクティブシートとして表示
End Sub

関連記事
スポンサーサイト
* スポンサーサイトエクセルVBA(その2)へのコメント *
なんやようわからんけど
Uちゃんもちゃんとお仕事してんだな~
てなことは、判ったような気がします。
今度又飲もうね~

結構まじめに仕事してるでしょ(^^v

で、先ほどは「飲み」のお誘いありがとうございましたぁ~!!(^^v
明日はお休みなんですが、夕方から送別会。
眼鏡を壊さないように飲んできまぁ~す!?(^^;;
新鮮な「魚神と魚弱」が食いたぁ~い!!(^^v

おじゃまします
配筋図をエクセルで書くプログラムを探してここにたどり着きましたw
このソースでエクセルを再現しようとしましたがどうにもうまくいきません('A`)
もしよければこのエクセルファイルを頂けないでしょうか?
突然勝手な申し出してすいません(´・ω・)

コメントありがとうございます。と同時にまさかの申し出に戸惑っております(^^;

確かに記事に書いたマクロだけで再現するのはとても難しいと思います。
諸事情あるため、お譲りするのは難しいです。スイマセン(^^;

もし、私のよく知る同業社の技術屋さんなら・・・と思いましたが、まさかねぇ~(^^;

そぉですか…わかりました。
ご丁寧にありがとうございます(´∀`)

心が折れそうですが再現頑張ってみますw

   

台風画報


ナショジオニュース

降水短時間予報

RSSフィード

月別アーカイブ

ブログ内の検索

プロフィール


  • Designed by Il mio diario
  • Powered by FC2BLOG
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。