[原创]批量CAD FAS2LSP转换程序的展示--作者：苏州 吴景怡

Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As String) As Long

Private Const WM_SETTEXT = &HC
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const WM_COMMAND = &H111
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202

Dim c As Long
Dim strstr333 As String

Rem 以16进制文字形式读取fas文件放入aa数组中,并显示到Text1文本框控件中
Private Sub DLL1(ByVal a As String)
    Dim i As Long
    Dim filenum As Long
    
    filenum = FreeFile
    
    Dim bytefile() As Byte
    
    Open a For Binary As #1
    aaa = LOF(1)
    If aaa = 0 Then aaa = 1
    
    ReDim bytefile(aaa - 1)
    Get #1, , bytefile
    Close #1
    
    ReDim b(aaa) As String
    ni = 0
    
    ReDim str11(aaa - 1) As String

    
    For i = 0 To aaa - 1
        If Len(Hex(bytefile(i))) = 1 Then
        aa = "0" & Hex(bytefile(i)): a1 = 1
        Else
        aa = Hex(bytefile(i)): a1 = 0
        End If
        b(i) = aa
        
        If aa = "0A" Then ni = ni + 1
        If aa = "0A" And CStr(ni) = "2" Then shou1 = i '2
        If aa = "0A" And CStr(ni) = "3" Then wei1 = i '3
        
        str11(iaasa) = aa
        iaasa = iaasa + 1
        
        
        If a1 = 1 Then a1 = 0
        DoEvents
    Next
    
    RichTextBox1 = Join(str11, " ")
    
    Call aa1(b, shou1 + 1, wei1 - 2, aaa)
    
    Clipboard.Clear
    Clipboard.SetText strstr333

    Open "D:\a.txt" For Output As #3
     
    Print #3, a
    Close #3
    Sleep 2000
    Shell App.Path & "\vfset.exe", vbNormalFocus
End Sub

Private Function aa1(ByRef b() As String, ByVal shou1 As Long, ByVal wei1 As Long, ByVal aaa As Long)

   a2 = 0
   aa2 = 0
   

   For iii = shou1 To wei1
       If b(iii) = "0A" Then
       shou2 = iii + 1
       
       
       End If
       If b(iii) = "20" Then
       wei2 = iii - 1
       
       End If
   Next
   If shou2 = "" Then shou2 = shou1
   If wei2 = "" Then wei2 = wei1
   For iaa = shou2 To wei2
   
   kkk1 = kkk1 & Chr("&H" & b(iaa))
   Next
   
   Form1.Caption = wei2
   
   a2 = 0
   ddd = 0
   ccc = 0
   eee = 0
   aa2 = 0
   
   For iiii = Val(Form1.Caption) To aaa
       If Val(b(iiii)) = 24 Then
          a2 = a2 + 1
       End If
       If Val(b(iiii)) = 20 Then
          aa2 = aa2 + 1
       End If
       If Val(b(iiii)) = 24 And a2 = 1 Then
          ccc = iiii
       End If
       If Val(b(iiii)) = 24 And a2 = 2 Then
          eee = iiii
       End If
       If Val(b(iiii)) = 20 And aa2 = 1 Then
          ddd = iiii
       End If
       DoEvents
   Next
   
   
   For iiiii = shou2 To wei2
       str2 = str2 & Chr("&H" & b(iiiii))
       DoEvents
   Next
 
   str2 = str2
   For iiiiii = ccc + 1 + str2 + 1 To aaa - 1
       If b(iiiiii) = "24" Then
       fff1 = iiiiii
       GoTo a2
       End If
       
       DoEvents
   Next
a2:
   For iiiiii = ccc + 1 + str2 + 1 To aaa - 1
       If b(iiiiii) = "20" Then
       fff = iiiiii
       GoTo a1
       End If
       
       DoEvents
   Next
a1:
   For ii11 = ccc + 1 + str2 + 1 To fff - 1
   str1 = str1 & Chr("&H" & b(ii11))
   Next
   

   n = 1
   aaaaa111 = Val(str1)
   
   ReDim ccc1(aaaaa111) As String
   For iiiiii = fff1 + 1 To Val(str1) + fff1 + 1
        ccc1(aai) = b(iiiiii)
       aai = aai + 1
       DoEvents
   Next
   Dim strstr111 As String
   
   strstr111 = Join(ccc1, " ")
  
   For iia = Val(str1) + fff + 4 To aaa
   If b(iia) = "24" Then
   bi = iia - 1
   End If
   Next
   
   For iiia = Val(str1) + fff1 + 2 To bi
       str3 = str3 & b(iiia) & " "
       
   Next
   
   
   
   strstr222 = Trim(str3)
    Text2 = strstr222
   ReDim d(UBound(b) - 1) As String
   
   Dim a() As String
   a = Split(Trim(strstr111), " ")
   nn = UBound(Split(Trim(strstr222), " ")) + 1
   ccc1 = Split(Trim(strstr222), " ")
   
   For i1 = 0 To UBound(a) - 1
   i2 = i2 + 1
   If i2 = nn * n Then
   i2 = 0
   d(i1) = Val("&H" & a(i1)) Xor Val("&H" & ccc1(i2))
   
   
   d(i1) = Hex(Val("&H" & ccc1(nn - 1)) Xor d(i1))
   Else
   
   d(i1) = Val("&H" & a(i1)) Xor Val("&H" & ccc1(i2))
   
   
   d(i1) = Hex(d(i1) Xor Val("&H" & ccc1(i2 - 1)))
   End If
   If Len(d(i1)) = 1 Then d(i1) = "0" & d(i1)
   
   If i2 = nn * n Then n = n + 1
   Next
  llll = 0
  

   sum3 = Join(d, " ")
   Debug.Print sum3

   Dim mb() As String
   
   mb = Split(sum3, " ")
   
   For i = 0 To UBound(mb) - 1
   If mb(i) = "55" Then
   nnnn = i
   GoTo m0
   
   ElseIf mb(i) = "56" Then
   nnnn = i
   GoTo m0
   
   ElseIf mb(i) = "5B" Then
   nnnn = i
   GoTo m0
   
   End If
   Next
   
m0:
   遍1 = Mid(sum3, 1 + nnnn * 3, 2)
   strstr333 = Mid(Trim(sum3), InStr(1, Trim(sum3), 遍1, vbTextCompare), Len(Trim(sum3)))
   
   
   
   Text1 = strstr111
   Text3 = strstr333
   Debug.Print strstr333
End Function

Rem 本程序为cad 批量fas转lsp程序，不需要安装cad就能直接转换，现仅支持转换不加密的fas。
Rem 本代码仅解决批量转换功能，主要转换核心是别人所写，本代码仅作技术交流。

Private Sub Form_Load()
   Dim name1(10000) As String
   
   ii = 0
   aaa = "f2l.exe"
   bbb = "vfl.set"
   Form1.CommonDialog1.Filter = "CAD FAS文件（*.fas)|*.fas"
   Form1.CommonDialog1.ShowOpen
   FileName = Form1.CommonDialog1.FileName
   If FileName = "" Then End
   
   jj = InStrRev(FileName, "\")
  
   If Dir("D:\Temp" & "\", vbDirectory) = "" Then
     MkDir "D:\Temp" & "\"
   End If
   
   Dim arr
   Dim i As Long
   arr = Split(FileName, Chr(0))
   i = InStrRev(arr(0), "\")
   
   If i > 0 Then
        filepath = Left(arr(0), i - 1)
   End If
    
   kkkkkk = filepath
    
   name12 = Dir(kkkkkk & "\*.fas", vbNormal)
   
kk:
   DoEvents

   Call FileCopy(filepath & "\" & name12, "D:\Temp" & "\" & name12)
a11:
   
   If FileName = "" Then
      name12 = Dir(kkkkkk & "\*.fas", vbNormal)
      
      
      If name12 = "" Then Exit Sub
      FileCopy kkkkkk & "\" & name12, "D:\Temp" & "\" & name12
   End If
   

   ii = ii + 1
   

   filepath1 = filepath
   filepath = "D:\Temp" & "\"
   

  FileName = ""
  

 Call DLL1(kkkkkk & "\" & name12)

 
  Sleep 2000
 DoEvents

a22:
  kkkkk = 0

  If FileLen(filepath & name12) > 200000 Then Sleep 100000

a2:
  DoEvents
  Sleep 1000
  d2 = FindWindow("#32770", "fastolsp")
  d3 = FindWindow("#32770", "fas2lsp v1.10")
  d1 = FindWindow("WindowsForms10.Window.8.app.0.378734a", "Microsoft .NET Framework")
  If d1 > 0 Or d2 > 0 Or d3 > 0 Then
  Sleep 3000

  Shell "cmd.exe /c taskkill /im " & aaa & " /f", vbHide
  Sleep 1000

  Shell "cmd.exe /c taskkill /im " & bbb & " /f", vbHide

   Shell "cmd.exe /c taskkill /im " & aaa & " /f", vbHide
  Sleep 1000

  Shell "cmd.exe /c taskkill /im " & bbb & " /f", vbHide
    Sleep 1000
   Shell "cmd.exe /c taskkill /im " & aaa & " /f", vbHide
  Sleep 1000
   Shell "cmd.exe /c taskkill /im " & bbb & " /f", vbHide
  Sleep 1000
  ElseIf d1 = 0 And d2 = 0 And d3 = 0 And kkkkk >= 20 Then
  GoTo a3

  Else
    kkkkk = kkkkk + 1
  GoTo a2

  End If
a3:
  DoEvents
  Sleep 1000

  e = FindWindowEx(d, 0, "Button", vbNullString)
  If d3 > 0 Then
  Call SendMessage(e, &HF5, 0, ByVal 0)
  ElseIf d3 = 0 And kkkkk > 20 Then
  GoTo a4

  Else
  kkkkk = kkkkk + 1

  GoTo a2
  End If
a4:

  name13 = name12

  jj = InStrRev(name13, "\")

  If Dir(kkkkkk & "\" & "函数.lsp", vbNormal) <> "" Then
     Name kkkkkk & "\" & "函数.lsp" As filepath & Mid$(name12, jj + 1, Len(name12) - jj - 4) & "_函数.lsp"
  End If

  If Dir(kkkkkk & "\" & "函数v.lsp", vbNormal) <> "" Then
     Name kkkkkk & "函数v.lsp" As filepath1 & Mid$(name12, jj + 1, Len(name12) - jj - 4) & "_函数v.lsp"
  End If

  FileCopy kkkkkk & "\" & Mid$(name12, jj + 1, Len(name12) - jj), "D:\Temp" & "\" & name12
  FileCopy kkkkkk & "\" & Mid$(name12, jj + 1, Len(name12) - jj - 4) & ".fas.lsp", "D:\Temp" & "\" & Mid$(name12, jj + 1, Len(name12) - jj - 4) & ".fas.lsp"

  SetAttr kkkkkk & "\" & name12, vbHidden

  FileName = ""

  If Dir(filepath1 & "\*.fas", vbNormal) <> "" Then GoTo a11

End Sub
 
VX:15850109865