AutoCAD SCR腳本檔 匯入Excel佈點 (2022) | 有字幕

Sub test()
    
    Dim Point_file As Workbook, Get_Path As Object, Default_Path As Variant, xls_fullpath As Variant
    Dim F As Integer, AllData As String, FileName As String, RowData
    
'路徑預設，我的電腦，也可改用其它路徑代替，例如 c:\test\  、ThisWorkbook.Path
    Default_Path = &H11& 'My computer

    Set Get_Path = CreateObject("Shell.Application").BrowseForFolder(0, "choose a folder", &H201, Default_Path)
    
      If Get_Path Is Nothing Then
        MsgBox "???"
        Exit Sub
    End If

    For Each xls_fullpath In Get_Path.items
    
        DoEvents
        
'檔名可用萬用字元過濾
'預設開啟同目錄下(1層，不含子目錄)，所有xlsx 檔(第一個工作表)，轉成.scr

        If xls_fullpath.Path Like "*.xlsx" And Not xls_fullpath.isfolder And xls_fullpath.Name & ".xlsm" <> ThisWorkbook.Name Then
            
            Set Point_file = Workbooks.Open(xls_fullpath.Path, , False)
               
            F = FreeFile
            AllData = ""
            
            FileName = Get_Path.self.Path & "\" & xls_fullpath.Name & ".scr"
            Open FileName For Output As #F
            For Each RowData In Point_file.Sheets(1).Range("a1").CurrentRegion.Rows
                AllData = AllData & "POINT " & Join(Application.Transpose(Application.Transpose(RowData)), ",") & vbNewLine
            Next
            Print #F, AllData
            Close #F
            
            Point_file.Close 1
            Set Point_file = Nothing
            
            'debug
            Shell ("C:\Windows\system32\notepad.exe" & " " & FileName), vbNormalFocus
            
        End If
         
    Next
    
    Set Get_Path = Nothing
    

End Sub

snare wrote:
簡易vba，給您玩看(恕刪)