Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


28094 / 76732 ←次へ | 前へ→

【53946】Re:置き換えプログラム
回答  みそじのおじさん  - 08/2/17(日) 18:25 -

引用なし
パスワード
   こんばんは。maさんもう見ていないかな?

私はmaさんと同じ機械加工業をしている物です。(いつもは質問者です。)

maさんが提示されたデータはJISで規定されている、工作機械を動かす為の

Gコードと呼ばれるNCプログラムです。(みなさんがいま触っているマウスも

こういうデータによって、金属を機械で削り出してオス、メスの金型がつくら

れ出来ています。)私もNCプログラムをあれこれいじるプログラムをVBAでよ

く作るので、興味があって作ってみました。

maさんのやりたかった事が 次工具を呼ぶのをやめて、工具交換⇒工具長⇒

加工⇒工具交換⇒工具長⇒加工⇒終了 だったとすると(私が見た限りでは

こう解釈しましたが....違いました?)


標準モジュールにこれをコピーして下さい。実行するとファイル選択の

ダイアログがでてくるので、変換するプログラムを選択して下さい。

(選択したファイルを書き換えてしまう為、念のためファイルコピー

をしておいた方がいいです)


Sub NC_PRO_CHANGE()

Dim FlName As String
Dim i As Integer
Dim myTxt As String
Dim MyPRO() As String
Dim LineCount As Long
Dim M06Fg As Integer, HitFg As Integer
Dim myHNo As Integer, myTNo As Integer
Dim M06Count As Integer
Dim l As Long
Dim p As Integer, findH As Integer, pp As Integer

Dim hanteiMOJI(1 To 13) As String

hanteiMOJI(1) = "0"
hanteiMOJI(2) = "1"
hanteiMOJI(3) = "2"
hanteiMOJI(4) = "3"
hanteiMOJI(5) = "4"
hanteiMOJI(6) = "5"
hanteiMOJI(7) = "6"
hanteiMOJI(8) = "7"
hanteiMOJI(9) = "8"
hanteiMOJI(10) = "9"
hanteiMOJI(11) = "-"
hanteiMOJI(12) = "."
hanteiMOJI(13) = " "

On Error GoTo ERR_TRAP:

i = FreeFile

FlName = Application.GetOpenFilename()

If FlName = "False" Then Exit Sub

 M06Count = 0
 LineCount = 0
 M06Fg = 0
 myHNo = 0
 myTNo = 0

Open FlName For Input As #i
 Do Until EOF(i)
   Line Input #i, myTxt
    LineCount = LineCount + 1
     ReDim Preserve MyPRO(1 To 1, 1 To LineCount) As String
     
      MyPRO(1, LineCount) = myTxt
 Loop
Close #i

For l = 1 To UBound(MyPRO, 2)
 If Left(MyPRO(1, l), 3) = "M06" Then
   M06Fg = 1: m06row = l: M06Count = M06Count + 1
 End If
 
 
 If Left(MyPRO(1, l), 1) = "O" Or Left(MyPRO(1, l), 1) = "$" Or Left(MyPRO(1, l), 1) = "(" Then
 Else
  
    If InStr(1, MyPRO(1, l), "H") > 0 And M06Fg = 1 Then
     findH = InStr(1, MyPRO(1, l), "H")


      For pp = findH + 1 To Len(MyPRO(1, l))
      For p = 1 To 13
      HitFg = 0
       If Mid(MyPRO(1, l), pp, 1) = hanteiMOJI(p) Or pp = Len(MyPRO(1, l)) Then
        HitFg = 1
        If pp = Len(MyPRO(1, l)) Then pp = pp + 1: HitFg = 0
        
        Exit For
       End If
      Next
      
      If HitFg = 0 Then
        myHNo = Mid(MyPRO(1, l), findH + 1, pp - (findH + 1))
        Exit For
      End If
      
      
     Next
    End If
    
   If InStr(1, MyPRO(1, l), "T") > 0 And M06Count >= 1 Then
     findH = InStr(1, MyPRO(1, l), "T")
     
      HitFg = 0
     
      For pp = findH + 1 To Len(MyPRO(1, l))
      
      For p = 1 To 13
        HitFg = 0
       If Mid(MyPRO(1, l), pp, 1) = hanteiMOJI(p) Or pp = Len(MyPRO(1, l)) Then
        HitFg = 1
        If pp = Len(MyPRO(1, l)) Then pp = pp + 1: HitFg = 0
        Exit For
       End If
      Next
      
      If HitFg = 0 Then
        myTNo = Mid(MyPRO(1, l), findH + 1, pp - (findH + 1))
       
        myTrow = l
        MyPRO(1, l) = WorksheetFunction.Replace(MyPRO(1, l), findH, Len(myTNo) + 1, "")
        Exit For
      End If
      
      
     Next
   End If
    
    If M06Count = 1 Then
      M06Fg = 0: myHNo = 0: myTNo = 0
     
    Else
      If M06Fg = 1 And myHNo <> 0 Then
        MyPRO(1, m06row) = "G49M06T" & myHNo
        M06Fg = 0: myHNo = 0
      End If
    End If
    
 End If
 
Next

Open FlName For Output As #i

  For pp = 1 To UBound(MyPRO, 2)
   Print #i, MyPRO(1, pp)
  Next
  
Close #i

MsgBox "変換が終了しました。"
Exit SUb

ERR_TRAP:

End Sub


maさんはプログラムの先頭を省略していましたが、私の推測で最初の

工具交換指令までなくなっては困ると思い一回目のT**はそのまま残る

用にしてあります。なのでここに提示されているデータでは変換はされ

ません。(対応しているのは工具交換指令が2回以上あるデータに対して

有効です。)    これも推測ですが、機械の対話もしくはCAD-CAM

でプログラムを作成されているなら関係ありませんが、手打ちで作っ

ている場合、M06をM6とした場合は変換されませんのでご注意を。
0 hits

【53601】置き換えプログラム ma 08/1/24(木) 8:44 質問
【53602】Re:置き換えプログラム neptune 08/1/24(木) 10:50 発言
【53603】Re:置き換えプログラム neptune 08/1/24(木) 10:57 発言
【53604】Re:置き換えプログラム ma 08/1/24(木) 11:25 お礼
【53606】Re:置き換えプログラム わいわい 08/1/24(木) 12:14 発言
【53611】Re:置き換えプログラム VBWASURETA 08/1/24(木) 17:35 発言
【53612】Re:置き換えプログラム わいわい 08/1/24(木) 18:56 発言
【53615】Re:置き換えプログラム VBWASURETA 08/1/24(木) 20:46 発言
【53946】Re:置き換えプログラム みそじのおじさん 08/2/17(日) 18:25 回答

28094 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free