admin menu ≫  image  writes  admin
スポンサーサイト 
--.--.--.-- 
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
まだまだ続くVBA!?(^^; 
2009.03.11.Wed 
オートシェイプで漫画が書けたので(^^v
次はVBAで、オートシェイプ用のデータから、JWW用のDXFデータのファイル出力をしてみる!?
まだ途中だけど・・・なんとなく出来そうな予感(^^



Sub test()
  Const ForReading = 1, ForWriting = 2, ForAppending = 8
  Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
  Dim Temp_fs, Temp_f, Temp_ts, str
  Dim fs, f, ts
  Set fs = CreateObject("Scripting.FileSystemObject")
  fs.CreateTextFile ThisWorkbook.Path & "jww.dxf"
  Set f = fs.GetFile(ThisWorkbook.Path & "jww.dxf")
  Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
  Set Temp_fs = CreateObject("Scripting.FileSystemObject")
  Set Temp_f = Temp_fs.GetFile(ThisWorkbook.Path & "jwTemp.txt")
  Set Temp_ts = Temp_f.OpenAsTextStream(ForReading, TristateUseDefault)
  Do
    str = Temp_ts.ReadLine
    If str = "EOF" Then Exit Do
    ts.Write str + vbCrLf
  Loop
  Temp_ts.Close
  Call DxfApp(ts)
  ts.Close
End Sub
-----------------
Sub DxfApp(ts)
Dim DataSheet
Dim st, Column(26) As String
Dim Column1, Column2, Row, color As Integer
Dim fig As Integer
Dim data(30) As Single
Dim B, H, D, R, n As Single
  Set DataSheet = Worksheets("作図データ")
  B = DataSheet.Range("C" & 3).Value
  H = DataSheet.Range("C" & 4).Value
  D = DataSheet.Range("C" & 11).Value
  R = DataSheet.Range("C" & 12).Value
  n = DataSheet.Range("C" & 14).Value
  fig = DataSheet.Range("I" & 4).Value
  Column(1) = "A"
  Column(2) = "B"
  Column(3) = "C"
  Column(4) = "D"
  Column(5) = "E"
  Column(6) = "F"
  Column(7) = "G"
  Column(8) = "H"
  Column(9) = "I"
  Column(10) = "J"
  Column(11) = "K"
  Column(12) = "L"
  Column(13) = "M"
  Column(14) = "N"
  Column(15) = "O"
  Column(16) = "P"
  Column(17) = "Q"
  Column(18) = "R"
  Column(19) = "S"
  Column(20) = "T"
  Column(21) = "U"
  Column(22) = "V"
  Column(23) = "W"
  Column(24) = "X"
  Column(25) = "Y"
  Column(26) = "Z"
  str = ""
'平面図座標
  color = 4
  Row = 22
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
  If fig <> 0 Then
    Row = 7
    Call DxfLine(ts, DataSheet, Column, 9, 12, Row, data, color, st)
  End If
'断面図外側座標
  Row = 98
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'断面図内側座標
  Row = 105
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'側面図座標
  Row = 274
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
  If fig <> 0 Then
    Row = 274
    Call DxfLine(ts, DataSheet, Column, 9, 12, Row, data, color, st)
  End If
'中心線
  Row = 22
  Call DxfLine(ts, DataSheet, Column, 8, 11, Row, data, color, st)
'平面図:主筋座標
  color = 7
  Row = 33
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
  Call DxfLine(ts, DataSheet, Column, 10, 13, Row, data, color, st)
  If fig <> 0 Then
    Row = 14
    Call DxfLine(ts, DataSheet, Column, 9, 12, Row, data, color, st)
  End If
'平面図:配力筋
  Row = 74
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
  Row = 86
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'平面図:ハンチ筋
  Row = 33
  Call DxfLine(ts, DataSheet, Column, 17, 20, Row, data, color, "N")
  Call DxfLine(ts, DataSheet, Column, 21, 24, Row, data, color, "N")
'平面図:外側主鉄筋寸法線
  If fig = 0 Then
    Row = 57
  Else
    Row = 611
  End If
  color = 4
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'平面図:内側主鉄筋寸法線
  If fig = 0 Then
    Column1 = 6
    Column2 = 9
    Row = 57
  Else
    Column1 = 8
    Column2 = 11
    Row = 611
  End If
  Call DxfLine(ts, DataSheet, Column, Column1, Column2, Row, data, color, st)
'断面図:内側鉄筋
  color = 7
  Row = 116
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'断面図:外側鉄筋
  Row = 123
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'断面図:ハンチ筋
  Row = 130
  Call DxfLine(ts, DataSheet, Column, 2, 5, Row, data, color, st)
'断面図:偶角部
  Row = 138
  Call DxfMage(ts, DataSheet, Column, 2, Row, R, data, color, st)
'断面図配力筋
Dim out_n, in_n As Integer
  '頂底版:右側壁配力筋
  Column1 = 2
  Row = 222
  out_n = DataSheet.Range("J" & Row).Value / 2
  in_n = DataSheet.Range("K" & Row).Value / 2
  Call DxfMacro30(ts, DataSheet, Column, Column1, Row, out_n, in_n, data, color, st)
  '頂底版:左側壁配力筋
  Row = 235
  Call DxfMacro30(ts, DataSheet, Column, Column1, Row, out_n, in_n, data, color, st)
  '側壁:頂版側配力筋
  Column1 = 2
  Row = 248
  out_n = DataSheet.Range("J" & Row).Value / 2
  in_n = DataSheet.Range("K" & Row).Value / 2
  Call DxfMacro30(ts, DataSheet, Column, Column1, Row, out_n, in_n, data, color, st)
  '側壁:底版側配力筋
  Row = 261
  Call DxfMacro30(ts, DataSheet, Column, Column1, Row, out_n, in_n, data, color, st)
'DXFファイルの書込み完了
  ts.Write "ENDSEC" + vbCrLf
  ts.Write " 0" + vbCrLf
  ts.Write "EOF" + vbCrLf
End Sub
-----------------------
Sub DxfMacro30(ts, DataSheet, Column, Column1, Row, out_n, in_n, data, color, st)
Dim i, j, k As Integer
Dim cx(4), cy(4) As Single
  For i = 1 To out_n
    k = Column1
    For j = 1 To 4
      cx(j) = DataSheet.Range(Column(k) & Row).Value: k = k + 1
      cy(j) = DataSheet.Range(Column(k) & Row).Value: k = k + 1
    Next
    Call DxfCircleLine(ts, 0, 360, 30, 0.75, cx(1), cy(1), data, color, st)
    Call DxfCircleLine(ts, 0, 360, 30, 0.75, cx(4), cy(4), data, color, st)
    If i <= in_n Then
      Call DxfCircleLine(ts, 0, 360, 30, 0.75, cx(2), cy(2), data, color, st)
      Call DxfCircleLine(ts, 0, 360, 30, 0.75, cx(3), cy(3), data, color, st)
    End If
    Row = Row + 1
  Next
End Sub
----------------------------
Sub DxfLine(ts, DataSheet, Column, Column1, Column2, DataRow, data, color, st)
Dim i, j, Row As Integer
  Row = DataRow
  Do
    j = 1
    For i = Column1 To Column2
      Sell = Column(i) & Row: data(j) = DataSheet.Range(Sell).Value
      j = j + 1
    Next
    If st <> "" Then
      data(0) = DataSheet.Range(st & Row).Value
      data(2) = data(2) + 0.5
      data(4) = data(2)
    Else
      data(0) = 1
    End If
    If data(1) = 0 Then Exit Do
    If 0 < data(0) * data(1) Then
      Call DxfWrite(ts, data, color, st)
    End If
    Row = Row + 1
  Loop
End Sub
-------------------
Sub DxfMage(ts, DataSheet, Column, j, Row, R, data, color, st)
Dim i As Integer
Dim cx(5), cy(5) As Single
Dim StA, EdA, increment_A As Single
  For i = 1 To 4
    Sell = Column(j) & Row: cx(i) = DataSheet.Range(Sell).Value
    Sell = Column(j + 1) & Row: cy(i) = DataSheet.Range(Sell).Value
    Row = Row + 1
  Next
  StA = 0
  EdA = 90
  increment_A = 15
  For i = 1 To 4
    Call DxfCircleLine(ts, StA, EdA, increment_A, R, cx(i), cy(i), data, color, st)
    StA = EdA
    EdA = EdA + 90
  Next
End Sub
-------------------------
Sub DxfCircleLine(ts, StA, EdA, increment_A, R, x, y, data, color, st)
Dim StartA, EndA As Single
Dim Pai As Double
  Pai = 3.14159265358979 / 180
  StartA = StA
  EndA = EdA
  j = increment_A
  EndA = EndA - j
  For i = StartA To EndA Step j
    data(1) = x + R * Sin(i * Pai)
    data(2) = y + R * Cos(i * Pai) * -1
    data(3) = x + R * Sin((i + j) * Pai)
    data(4) = y + R * Cos((i + j) * Pai) * -1
    Call DxfWrite(ts, data, color, st)
  Next
End Sub
---------------------------------
Sub DxfWrite(ts, data, color, st)
Dim Jww_Y As Double
  Jww_Y = 7073
  ts.Write "LINE" + vbCrLf
  ts.Write " 8" + vbCrLf
  ts.Write "_0-0_通り芯" + vbCrLf
  ts.Write " 6" + vbCrLf
  ts.Write "CONTINUOUS" + vbCrLf
  ts.Write " 62" + vbCrLf
  ts.Write " " + str(color) + vbCrLf
  ts.Write " 10" + vbCrLf
  ts.Write str(data(1) * 10) + vbCrLf
  ts.Write " 20" + vbCrLf
  ts.Write str(Jww_Y - data(2) * 10) + vbCrLf
  ts.Write " 11" + vbCrLf
  ts.Write str(data(3) * 10) + vbCrLf
  ts.Write " 21" + vbCrLf
  ts.Write str(Jww_Y - data(4) * 10) + vbCrLf
  ts.Write " 0" + vbCrLf
End Sub
関連記事
スポンサーサイト
* スポンサーサイトまだまだ続くVBA!?(^^;へのコメント *
   

台風画報


ナショジオニュース

降水短時間予報

RSSフィード

月別アーカイブ

ブログ内の検索

プロフィール


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