admin menu ≫  image  writes  admin
スポンサーサイト 
--.--.--.-- 
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
エクセルVBAで苦戦(^^; 
2009.02.07.Sat 
今週は、エクセルVBAで遊んでましたぁ??!!っていえるのかな?
初めて使ってみて結構使えるんでびっくりしましたが、いま苦戦してまぁ?す(^^;
で、何やってたかってというと(^^;・・・
エクセルのマクロ使いながら、VBAヘルプやその手のネット検索しながら
やっとやっと↓まで辿り着きました。判る人には判るはず・・・まだ途中ですが(^^;
で、いま悩んでるのが・・・途中にある長ったらしい「If?End If文」が、何とかならないかと(^^;
ここ2、3日集中してやってんで、どうなってるか判ってるつもりなんですが
1ヶ月も遠ざかったら、何が何だかさっぱり判らなくなるはず・・・絶対忘れるです!!
だったらコメント書いとけばぁ?と言われそうですが・・・コメント書く方がもっと大変!?(^^;
まだ出来てないから、もうちょっと遊ばなきゃいけないのに、忘れそうです(^^;


Sub Macro100()
' 2009/02/05
'エクセルのオートシェイプでボックスカルバートの配筋図を書いてみよう!!
'
 
  kumi = 1 '仮設定
 
  Sheets("配筋図").Select
  Set myDocument = Worksheets("配筋図")

'図形の削除
  myDocument.Shapes.SelectAll
  Selection.Cut

'////////////////////組立方法の設定//////////////////////////
 
  If kumi = 1 Then
   Set Sherchsheet = Worksheets("組立方法?数量表")
   Worksheets("配筋図").Range("A1").Value = Worksheets("組立方法?数量表").Range("A1").Value
  Else
   Set Sherchsheet = Worksheets("組立方法?数量表")
   Worksheets("配筋図").Range("A1").Value = Worksheets("組立方法?数量表").Range("A1").Value
  End If
 
'//////////////////////作図開始/////////////////////////////
 
Dim B, H, L, t1, t2, t3, C, d, R, sl, W2, p As Double

  B = Sherchsheet.Range("B7").Value * 100
  H = Sherchsheet.Range("C7").Value * 100
  L = Sherchsheet.Range("D7").Value * 100
  t1 = Sherchsheet.Range("B9").Value * 100
  t2 = Sherchsheet.Range("C9").Value * 100
  t3 = Sherchsheet.Range("D9").Value * 100
  C = Sherchsheet.Range("E9").Value * 100
  d = Sherchsheet.Range("E12").Value * 100
  R = Sherchsheet.Range("G12").Value * 100
  sl = Sherchsheet.Range("H12").Value * 100
  i = Int(Sherchsheet.Range("B12").Value)
  If kumi = 1 Then
   W2 = Sherchsheet.Range("E25").Value
  Else
   W2 = Sherchsheet.Range("E29").Value
  End If
 
  p = (L - 10#) / (i - 1)
  
'図形の原点

Dim stx, sty, edx, edy, ctx As Double
Dim stx1, sty1, edx1, edy1 As Double
Dim stx2, sty2, edx2, edy2 As Double

'外枠の座標

  stx = 100#
  sty = 100#
  edx = stx + B + t3 * 2
  'edy = sty + L + 2# * i
  ctx = (stx + edx) / 2# '中心線
 
'寸法線の設定
Dim R1, R2, R3 As Integer
Dim L1, L2, L3 As Integer

  R1 = 40 '引き出し線の長さ
  R2 = 35 '寸法線の位置
  R3 = R1 - 18 '寸法文字の位置
 
  L1 = 40 '引き出し線の長さ
  L2 = 35 '寸法線の位置
  L3 = 48 '寸法文字の位置

'主筋
 
  stx1 = stx + d
  sty1 = sty + 5#
  edx1 = ctx + sl / 2#
  edy1 = sty1
 
  stx2 = ctx - sl / 2#
  sty2 = sty1 + 2#
  edx2 = edx - d
  edy2 = sty2
 
  For n = 1 To i
   Call Line(myDocument, stx1, sty1, edx1, edy1, 1.5) '左
   sty2 = sty1 + 2#
   edy2 = sty2
   Call Line(myDocument, stx2, sty2, edx2, edy2, 1.5) '右
   If n = 1 Then
    If kumi = 1 Then
      Call Line(myDocument, stx - 3, sty1, stx - L1, edy1, 0.75) '左側寸法線
      Call Arrow(myDocument, stx - L2, edy1, "Top")
      Call Text(myDocument, stx - L3, edy2 - 20, 100, 100, "V", Format(50))
    End If
    Call Line(myDocument, edx + 3, sty2, edx + R1, edy2, 0.75) '右側寸法線
    Call Arrow(myDocument, edx + R2, edy2, "Top")
    Call Text(myDocument, edx + R3, edy2 - 20, 100, 100, "V", Format(W2 + 50))
   ElseIf n = i Then
    If kumi = 1 Then
      Call Line(myDocument, stx - 3, sty2, stx - L1, edy2, 0.75) '右側寸法線
      Call Arrow(myDocument, stx - L2, edy2, "Down")
    End If
    Call Line(myDocument, edx + 3, sty2, edx + R1, edy2, 0.75) '右側寸法線
    Call Arrow(myDocument, edx + R2, edy2, "Down")
   End If
   sty1 = sty1 + p
   edy1 = sty1
  Next
 
  edy = edy2 + 5#
 
'外枠
  Call Line(myDocument, stx, sty, edx, sty, 0.75)
  Call Line(myDocument, stx, edy, edx, edy, 0.75)
  Call Line(myDocument, stx, sty, stx, edy, 0.75)
  Call Line(myDocument, edx, sty, edx, edy, 0.75)
  str2 = Format(i - 1) & "@" & Format(Int(p * 10)) & "=" & Format(L * 10 - 100 - W2)
  If kumi = 1 Then
   Call Text(myDocument, stx - L3, (sty + edy) / 2 - 20, 100, 100, "V", str2) '主筋のピッチの記入
   Call Text(myDocument, stx - L3, edy, 100, 100, "V", Format(50 + W2)) '被りの記入
  End If
  Call Text(myDocument, edx + R3, (sty + edy) / 2 - 20, 100, 100, "V", str2) '主筋のピッチの記入
  Call Text(myDocument, edx + R3, edy, 100, 100, "V", Format(50)) '被りの記入

'左側寸法線
  If kumi = 1 Then
   Call Line(myDocument, stx - 3, sty, stx - L1, sty, 0.75)
   Call Arrow(myDocument, stx - L2, sty, "Down")
   Call Line(myDocument, stx - 3, edy, stx - L1, edy, 0.75)
   Call Arrow(myDocument, stx - L2, edy, "Top")
 
   Call Line(myDocument, stx - L2, sty - 10, stx - L2, edy + 10, 0.75)
  End If
 
'右側寸法線
  Call Line(myDocument, edx + 3, sty, edx + R1, sty, 0.75)
  Call Arrow(myDocument, edx + R2, sty, "Down")
  Call Line(myDocument, edx + 3, edy, edx + R1, edy, 0.75)
  Call Arrow(myDocument, edx + R2, edy, "Top")
 
  Call Line(myDocument, edx + R2, sty - 10, edx + R2, edy + 10, 0.75)
 
'配力筋のピッチの計算

Dim PT(21) As Double
Dim Bd As Double

  For n = 0 To 20
   PT(n) = 0#
  Next
 
  j = Int(Sherchsheet.Range("F27").Value / 2) '配力筋の本数1/2

  PT(1) = 15# 'センターからのピッチ
  For n = 2 To j + 1
   PT(n) = 30#
  Next n
  
  If B <= 140 Then
   Bd = B - 3
   If j = 2 Then
    PT(j) = (Bd - 30) / 2
    If 30 < PT(j) Then
      PT(j) = 30
    End If
   Else
    PT(j) = (Bd - 30 * 3) / 2
   End If
  Else
   Bd = B + d * 2 - 3
   PT(j) = (Bd - 30 * (j * 2 - 3)) / 2
   If PT(j) < 15 Then
    PT(j) = (PT(j) + 30) / 2
    PT(j - 1) = PT(j)
   End If
  End If
  
  
'配力筋と寸法線

  stx1 = ctx
  stx2 = ctx
 
  For n = 1 To j
   stx1 = stx1 + PT(n)
   edx1 = stx1
   sty1 = sty + 2#
   edy1 = edy - 2#
   Call Line(myDocument, stx1, sty1, edx1, edy1, 1.5) '右
   stx2 = stx2 - PT(n)
   edx2 = stx2
   Call Line(myDocument, stx2, sty1, edx2, edy1, 1.5) '左
   If n = j - 1 Then
    If PT(n) <> 30 Then
      Call Line(myDocument, stx1 - PT(n), edy + 3, edx1 - PT(n), edy + R1, 0.75) '右引き出し線
      Call Line(myDocument, stx2 + PT(n), edy + 3, edx2 + PT(n), edy + R1, 0.75) '左引き出し線
      Call Arrow(myDocument, stx1 - PT(n), edy + R2, "Right")
      Call Arrow(myDocument, stx2 + PT(n), edy + R2, "Left")
      Call Arrow(myDocument, stx1 - PT(n), edy + R2, "Left")
      Call Arrow(myDocument, stx2 + PT(n), edy + R2, "Right")
    End If
   End If
  
   If n = j Then
    Call Line(myDocument, stx1, edy + 3, edx1, edy + R1, 0.75) '右引き出し線
    Call Line(myDocument, stx2, edy + 3, edx2, edy + R1, 0.75) '左引き出し線
    If PT(n) <> 30 Then
      Call Line(myDocument, stx1 - PT(n), edy + 3, edx1 - PT(n), edy + R1, 0.75) '右引き出し線
      Call Line(myDocument, stx2 + PT(n), edy + 3, edx2 + PT(n), edy + R1, 0.75) '左引き出し線
      Call Arrow(myDocument, stx1 - PT(n), edy + R2, "Right")
      Call Arrow(myDocument, stx2 + PT(n), edy + R2, "Left")
      If PT(n) < 15 Then
       Call Line(myDocument, edx2 - 10, edy + R2, edx1 + 10, edy + R2, 0.75)
       Call Arrow(myDocument, stx1, edy + R2, "Left")
       Call Arrow(myDocument, stx2, edy + R2, "Right")
      Else
       Call Line(myDocument, edx2, edy + R2, edx1, edy + R2, 0.75)
       Call Arrow(myDocument, stx1 - PT(n), edy + R2, "Left")
       Call Arrow(myDocument, stx2 + PT(n), edy + R2, "Right")
       Call Arrow(myDocument, stx1, edy + R2, "Right")
       Call Arrow(myDocument, stx2, edy + R2, "Left")
      End If
    Else
      Call Line(myDocument, edx2, edy + R2, edx1, edy + R2, 0.75)
      Call Arrow(myDocument, stx1, edy + R2, "Right")
      Call Arrow(myDocument, stx2, edy + R2, "Left")
    End If
   End If
  Next
 
  If j = 2 Then
   If PT(2) <> 30 Then
    Call Text(myDocument, ctx - 10, edy + R3, 100, 100, "H", "300")
   Else
    Call Text(myDocument, ctx - 25, edy + R3, 100, 100, "H", "3@300=900")
   End If
  Else
   If PT(j) <> 30 Then
    If PT(j - 1) <> 30 Then
      Call Text(myDocument, ctx - 25, edy + R3, 100, 100, "H", Format(j * 2 - 5) & "@300=" & Format((j * 2 - 3) * 300))
      Call Text(myDocument, stx2 + PT(j), edy + R3, 100, 100, "H", Format(Int(PT(j - 1) * 10))) '左
      Call Text(myDocument, edx1 - PT(j) - PT(j - 1), edy + R3, 100, 100, "H", Format(Int(PT(j - 1) * 10))) '右
    Else
      Call Text(myDocument, ctx - 25, edy + R3, 100, 100, "H", Format(j * 2 - 3) & "@300=" & Format((j * 2 - 3) * 300))
    End If
    Call Text(myDocument, stx2, edy + R3, 100, 100, "H", Format(Int(PT(j) * 10))) '左
    Call Text(myDocument, edx1 - PT(j), edy + R3, 100, 100, "H", Format(Int(PT(j) * 10))) '右
  Else
    Call Text(myDocument, ctx - 25, edy + R3, 100, 100, "H", Format(j * 2 - 1) & "@300=" & Format((j * 2 - 1) * 300))
   End If
  End If
 
'断面図

  Call Danmen(myDocument, stx, edy + 100, B, H, t1, t2, t3, C, d, R)

'////////////////////頂底版の配筋図完了///////////////////

  myDocument.Shapes.SelectAll
  With Selection
   .Placement = xlFreeFloating
   .PrintObject = True
  End With
 
  myDocument.Shapes.SelectAll

End Sub

Sub Danmen(myDocument, x, y, B, H, t1, t2, t3, C, d, R)
'外断面
Dim sx(5), sy(5) As Double

  sx(1) = x
  sy(1) = y

  sx(2) = sx(1) + B + t3 * 2
  sx(3) = sx(2)
  sx(4) = sx(1)
  sy(2) = sy(1)
  sy(3) = sy(2) + H + t1 + t2
  sy(4) = sy(3)
 
  i = 4
  n = 0
  m = n Mod i + 1
  Do
   n = n + 1
   m = n Mod i + 1
   Call Line(myDocument, sx(n), sy(n), sx(m), sy(m), 0.75)
   If m = 1 Then Exit Do
  Loop

'内断面
Dim ux(10), uy(10) As Double

  ux(1) = sx(1) + t3
  ux(2) = ux(1) + C
  ux(4) = sx(2) - t3
  ux(3) = ux(4) - C
  ux(5) = ux(4)
  ux(6) = ux(3)
  ux(7) = ux(2)
  ux(8) = ux(1)

  uy(2) = sy(1) + t1
  uy(1) = uy(2) + C
  uy(3) = uy(2)
  uy(4) = uy(1)
 
  uy(6) = sy(3) - t2
  uy(5) = uy(6) - C
  uy(7) = uy(6)
  uy(8) = uy(5)

  i = 8
  n = 0
  m = n Mod i + 1
  Do
   n = n + 1
   m = n Mod i + 1
   Call Line(myDocument, ux(n), uy(n), ux(m), uy(m), 0.75)
   If m = 1 Then Exit Do
  Loop

'内側鉄筋
Dim tux(10), tuy(10) As Double
'頂版
  tux(1) = sx(1) + d
  tux(2) = sx(2) - d
  tuy(1) = uy(2) - d
  tuy(2) = tuy(1)
'右側壁
  tux(3) = ux(4) + d
  tux(4) = tux(3)
  tuy(3) = sy(2) + d
  tuy(4) = sy(3) - d
'底版
  tux(5) = sx(3) - d
  tux(6) = sx(4) + d
  tuy(5) = uy(6) + d
  tuy(6) = tuy(5)
'左側壁
  tux(7) = ux(1) - d
  tux(8) = tux(7)
  tuy(7) = tuy(4)
  tuy(8) = tuy(3)

  i = 8
  n = 0
  m = n Mod i + 1
  Do
   n = n + 1
   m = n Mod i + 1
   Call Line(myDocument, tux(n), tuy(n), tux(m), tuy(m), 1.25)
   n = n + 1
   If m = i Then Exit Do
  Loop

'外側鉄筋
Dim tsx(10), tsy(10) As Double
'頂版
  tsx(1) = tux(1) + R
  tsx(2) = tux(2) - R
  tsy(1) = tuy(8)
  tsy(2) = tuy(3)
'右側壁
  tsx(3) = tux(2)
  tsx(4) = tux(5)
  tsy(3) = tuy(3) + R
  tsy(4) = tuy(4) - R
'底版
  tsx(5) = tux(5) - R
  tsx(6) = tux(6) + R
  tsy(5) = tuy(4)
  tsy(6) = tuy(7)
'左側壁
  tsx(7) = tux(6)
  tsx(8) = tux(1)
  tsy(7) = tuy(7) - R
  tsy(8) = tuy(8) + R
 
  i = 8
  n = 0
  m = n Mod i + 1
  Do
   n = n + 1
   m = n Mod i + 1
   Call Line(myDocument, tsx(n), tsy(n), tsx(m), tsy(m), 1.25)
   n = n + 1
   If m = i Then Exit Do
  Loop

'偶角部の折り曲げの円の中心
Dim cx(5), cy(5) As Double
'右側壁上
  cx(1) = tux(2) - R
  cy(1) = tuy(3) + R
'右側壁下
  cx(2) = tux(5) - R
  cy(2) = tuy(4) - R
'左側壁下
  cx(3) = tux(6) + R
  cy(3) = tuy(7) - R
'左側壁上
  cx(4) = tux(1) + R
  cy(4) = tuy(8) + R
 
  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

'ハンチ筋の長さ
Dim Pai As Double
  Pai = 3.14159265358979 / 180
  TCL = (t1 + t3 + C - (d / Cos(45 * Pai) + d * 2)) / Cos(45 * Pai)
  BCL = (t2 + t3 + C - (d / Cos(45 * Pai) + d * 2)) / Cos(45 * Pai)

Dim hx(10), hy(10) As Double
 
'右上ハンチ筋
  hx(1) = tsx(3) - TCL * Cos(45 * Pai)
  hy(1) = tsy(2)
  hx(2) = tsx(3)
  hy(2) = tsy(2) + TCL * Cos(45 * Pai)
'右下ハンチ筋
  hx(3) = tsx(4)
  hy(3) = tsy(5) - BCL * Cos(45 * Pai)
  hx(4) = tsx(4) - BCL * Cos(45 * Pai)
  hy(4) = tsy(5)
'左下ハンチ筋
  hx(5) = tsx(7) + BCL * Cos(45 * Pai)
  hy(5) = tsy(6)
  hx(6) = tsx(7)
  hy(6) = tsy(6) - BCL * Cos(45 * Pai)
'左上ハンチ筋
  hx(7) = tsx(8)
  hy(7) = tsy(1) + TCL * Cos(45 * Pai)
  hx(8) = tsx(8) + BCL * Cos(45 * Pai)
  hy(8) = tsy(1)
  
  i = 8
  n = 0
  m = n Mod i + 1
  Do
   n = n + 1
   m = n Mod i + 1
   Call Line(myDocument, hx(n), hy(n), hx(m), hy(m), 1.25)
   n = n + 1
   If m = i Then Exit Do
  Loop
End Sub

Sub CircleLine(myDocument, StA, EdA, R, x, y)
'円
Dim StartA, EndA, 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 Line(myDocument, x1, y1, x2, y2, 1.25)
  Next
End Sub

Sub Line(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 Arrow(myDocument, x, y, str)
'矢印
  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 Line(myDocument, x, y, x1, y1, 0.75)
  Call Line(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()
'切取り
  Set myDocument = Worksheets("配筋図")
  myDocument.Shapes.SelectAll
  With Selection
   .Placement = xlMoveAndSize
   .PrintObject = True
  End With
  Selection.Cut
End Sub

いくつかサブルーチンがあるけど、多分使えないサブルーチンでしょ?(^^;

関連記事
スポンサーサイト
* スポンサーサイトエクセルVBAで苦戦(^^;へのコメント *
   

台風画報


ナショジオニュース

降水短時間予報

RSSフィード

月別アーカイブ

ブログ内の検索

プロフィール


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