想写一个批量插入文件的vba程序，但没有头绪？？

figolu

想写一个批量插入文件的程序，能调用所需用到的电子地图，以简化工作（不需要一幅一幅的进行插入），但不知道从哪里开始着手，请教高人指点！！

mccad

figolu

能告诉我如何调用插入图块的方法吗？另外，怎样才能实现批量插入的功能呢？

mccad

Sub InsBlk()
    ' 插入外部图形的例子
    Dim blockRefObj As AcadBlockReference
    Dim blkName As String
    blkName = "D:\1.dwg" '此处为图形的路径名称
    insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
    Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, blkName, 1#, 1#, 1#, 0)
   
    ZoomAll

End Sub

而批量插入则要看你是怎样选择图形的

figolu

比较经常用到的是以下两种模式：一是将文件夹中的所有文件插入，另一是选定数个文件一次性插入，请问上述两者都能实现吗？

mccad

首先工程中必须使用“CommonDialog-在VBA中使用的公用对话框模块”，见以下链接：
http://www.mjtd.com/mcdown/list.asp?id=83
开始工程前应输入CommonDialog.cls文件及modConstants.bas文件。
程序如下：

'通过选定多个图形文件插入到图形中的过程
Sub IntBlkBySelectDwg()
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 = getFileBySelect("选择图形：", "dwg", "AutoCAD图形文件(*.dwg)|*.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

'通过选定整个目录中的图形文件插入到图形中的过程
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

'选定多个文件的函数，使用了CommonDialog类
Public Function getFileBySelect(DialogTitle, DefaultExt, Filter) As Variant

Dim dlg As CommonDialog
Dim Files As Variant
Dim i As Integer

Set dlg = New CommonDialog
With dlg
    .DialogTitle = DialogTitle
    .DefaultExt = DefaultExt
    .Filter = Filter
    .Flags = OFN_EXPLORER Or OFN_HIDEREADONLY Or OFN_ALLOWMULTISELECT
    If .ShowOpen Then
        getFileBySelect = .ParseFileNames
    End If
End With

End Function

'返回指定目录下指定名称所有文件的函数
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

figolu

THANK YOU VERY MUCH!!
在您的帮助下，已经达到了批量插入的功能，希望以后能多向您请教。

3xxx

找了几天终于找到这个了。mcca太伟大了。我搜索“批量插入光栅图”或“批量插入图片”，没想到这个关键词是“批量插入文件”

3xxx

'通过选定多个图形文件插入到图形中的过程
试了一下，只能选择一个文件，cad2004版本

3xxx

这次试验成功，但是在cad2004之外的版本都不行了。难道那个commonDialog类有问题么？