通过选定整个目录中的图形文件插入到图形中的过程(zt)

通过选定整个目录中的图形文件插入到图形中的过程
Sub IntBlkByDirDwg()
On Error GoTo Err_Control
Dim BlkFile As Variant
Dim i As Integer
Dim InstPnt As Variant
Dim BlkRefObj As AcadBlockReference
Dim varCancel As Variant

BlkFile = GetDir("选择要插入图形所在的目录：", "*.dwg")

If IsArray(BlkFile) Then
    ThisDrawing.Utility.Prompt vbCrLf & " 你选定了" & Str(UBound(BlkFile) + 1) & "个图形"
    For i = 0 To UBound(BlkFile)
        
        InstPnt = ThisDrawing.Utility.GetPoint(, vbCrLf & " 请选择图形 " & JustFileName(BlkFile(i)) & " 的插入点：")
        Set BlkRefObj = ThisDrawing.ModelSpace.InsertBlock(InstPnt, _
                        BlkFile(i), 1#, 1#, 1#, 0#)
    Next

End If

Exit_Here:
  Exit Sub
Err_Control:
  Select Case Err.Number
    Case -2147352567
      varCancel = ThisDrawing.GetVariable("LASTPROMPT")
      If InStr(1, varCancel, "*Cancel*") <> 0 And InStr(1, varCancel, "*取消*") <> 0 Then
        Err.Clear
        Resume Exit_Here
      Else
        Err.Clear
        Resume
      End If
    Case -2145320928
      Err.Clear
      Resume Exit_Here
    Case Else
      Resume Exit_Here
  End Select

End Sub

'返回指定目录下指定名称所有文件的函数
Function GetFileListByPath(Path As String, FileName As String) As Variant

    Dim s As String
    Dim sFiles() As String
    Dim i As Integer
    s = Dir(Path & FileName)
    If s <> "" Then
     ReDim sFiles(i) As String
     sFiles(i) = Path & s
     i = 1
     s = Dir()
     While s <> ""
        ReDim Preserve sFiles(i) As String
        sFiles(i) = Path & s
        i = i + 1
        s = Dir()
     Wend
     GetFileListByPath = sFiles
    End If
    
End Function

'选定目录的函数，使用了commonDialog类
Public Function GetDir(DialogTitle As String, FileName As String) As Variant

Dim dlg As CommonDialog
Dim Path As String
Dim FileList As Variant

Set dlg = New CommonDialog
    dlg.DialogTitle = DialogTitle
    If dlg.Browse Then
        Path = dlg.Path
        If Path <> "" Then
            Path = Left$(Path, InStr(Path, vbNullChar) - 1)
            If Right$(Path, 1) <> "\" Then Path = Path & "\"
            FileList = GetFileListByPath(Path, "*.dwg")
            GetDir = FileList
        End If
    End If
        

End Function

'由文件全路径名称返回文件的函数
Public Function JustFileName(FileName) As String
On Error Resume Next
Dim count As Integer
For count = Len(FileName) - 1 To 1 Step -1
    If Mid(FileName, count, 1) = "\" Or Mid(FileName, count, 1) = "/" Then
        JustFileName = Right(FileName, Len(FileName) - count)
        Exit For
    End If
Next
End Function

本文地址：http://com.8s8s.com/it/it26667.htm