乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
楼主: Eloquintet

将初始打开目录设置为具有给定名称的文件夹

[复制链接]

48

主题

277

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
481
发表于 2007-3-22 10:51:50 | 显示全部楼层
Uggggh我觉得自己很迟钝。我有一个名为updateattribute的文件。参考commondialogue的dvb。dvb文件。我已经把你们的共同点,并把他们在更新文件的末尾。我仍然不确定在哪里放置init。直达线?我只是不知道你说的开始是什么意思,因为我记得vba没有#039;不要像lisp一样自上而下地阅读。本人'我会把所有的代码都贴出来,这样你就可以看到我看到了什么
  1. Option Explicit
  2. 'Stores block names & attributes for 1st inserted block of each
  3. Public AllBlocks As Scripting.Dictionary
  4. 'Stores attributes for selected block
  5. Public AllAttribs As Variant
  6. 'Macro for user interface
  7. Public Sub Ua()
  8.   Dim myFiles As Variant 'Stores filenames selected in array
  9.   myFiles = GetFiles 'Store filenames selected by user in array
  10.   
  11.   'AllBlocks is a public variable
  12.   Set AllBlocks = New Scripting.Dictionary 'Initialize storage
  13.   BlockDialog.BlockPicked = "" 'Initialize check variable
  14.   Set AttribDialog.AttribPicked = Nothing 'Initialize check variable
  15.   TextDialog.DoUpdate = False 'Initialize check variable
  16.   
  17.   'If files are selected
  18.   If IsArray(myFiles) Then
  19.     Dim myDoc As AcadDocument 'Need a variable for a drawing
  20.     'Get the first drawing selected by user
  21.     Set myDoc = AcadApplication.Documents.Open(myFiles(0))
  22.     GetBlocks myDoc, AllBlocks 'Get all attributed blocks in dwg
  23.   End If
  24.   
  25.   'There may be no attributed blocks, so need to test
  26.   If AllBlocks.Count > 0 Then BlockDialog.Show 'Show list of blocks
  27.   
  28.   'If a block was selected
  29.   If BlockDialog.BlockPicked  "" Then
  30.     'Store attributes from selected block in public variable
  31.     AllAttribs = AllBlocks.Item(BlockDialog.BlockPicked)
  32.     AttribDialog.Show 'Show list of attributes
  33.   End If
  34.   
  35.   'If an attribute was selected
  36.   If Not (AttribDialog.AttribPicked Is Nothing) Then
  37.     TextDialog.Show 'Display dialog to get new string
  38.   End If
  39.   
  40.   'If OK was hit in the TextDialog
  41.   If TextDialog.DoUpdate Then
  42.     'Change all the drawings the user selected
  43.     ProcessDrawings myFiles, _
  44.                     BlockDialog.BlockPicked, _
  45.                     AttribDialog.AttribPicked.TagString, _
  46.                     TextDialog.NewText
  47.    
  48.     'Inform the user things are done
  49.     MsgBox "Process is complete.", vbOKOnly, "ABC's of VBA"
  50.   Else
  51.     myDoc.Close False 'Close drawing left open during cancel
  52.   End If
  53. End Sub
  54. 'Open all given drawings and change selected attribute
  55. Private Sub ProcessDrawings(ByVal Dwgs As Variant, _
  56.                             ByVal BlockName As String, _
  57.                             ByVal TagName As String, _
  58.                             ByVal NewText As String)
  59.   'The following creates a selection set filter
  60.   Dim fType(0 To 1) As Integer 'Stores DXF-style codes
  61.   Dim fData(0 To 1) As Variant 'Stores filters
  62.   fType(0) = 0: fData(0) = "INSERT" 'Filter for block insertions
  63.   fType(1) = 2: fData(1) = BlockName 'Filter for specific block
  64.   
  65.   Dim openFilename As String 'Stores name of open drawing
  66.   Dim myDwg As AcadDocument 'Stores each drawing in turn
  67.   Dim mySS As AcadSelectionSet 'Stores selection set
  68.   Dim myAtts As Variant 'Stores attributes for each insertion
  69.   Dim i As Long, j As Long 'Declare two counters
  70.   
  71.   For i = 0 To UBound(Dwgs) 'Loop thru all drawings
  72.     openFilename = GetOpenFilename(Dwgs(i)) 'Checks if file is open
  73.     'If the drawing is open, just refer to open drawing
  74.     If openFilename  "" Then
  75.       Set myDwg = AcadApplication.Documents.Item(openFilename)
  76.     Else 'Open the drawing
  77.       Set myDwg = AcadApplication.Documents.Open(Dwgs(i))
  78.     End If
  79.    
  80.     Set mySS = GetSS(myDwg) 'Get a selection set
  81.    
  82.     'Populate the selection set with specified block insertions
  83.     mySS.Select Mode:=acSelectionSetAll, _
  84.                 FilterType:=fType, _
  85.                 FilterData:=fData
  86.                
  87.     For j = 0 To mySS.Count - 1 'Loop thru all selected blocks
  88.       ChangeAttrib mySS.Item(j), TagName, NewText 'Change attribute
  89.     Next j
  90.    
  91.     mySS.Delete 'Always delete a selection set when done with it
  92.     myDwg.Close Not myDwg.ReadOnly 'Close drawing, saving changes
  93.   Next i
  94. End Sub
  95. 'Checks to see if the given fully-qualified filename is open
  96. 'Returns the filename without path if it is open
  97. Private Function GetOpenFilename(fqnName As Variant) As String
  98.   Dim i As Long 'Declare a counter
  99.   'Loop thru all open drawings
  100.   For i = 0 To AcadApplication.Documents.Count - 1
  101.     'Use the document given below for its properties
  102.     With AcadApplication.Documents.Item(i)
  103.       'Compare two strings, if they match (equal 0) then return Name
  104.       If StrComp(.FullName, fqnName, vbTextCompare) = 0 Then
  105.         GetOpenFilename = .Name
  106.         Exit For 'Since a match was found, exit the loop
  107.       End If
  108.     End With
  109.   Next i
  110. End Function
  111. 'Returns a named selection set
  112. Private Function GetSS(ByRef theDoc As AcadDocument, _
  113.                        Optional ByVal Name As String = "mySS") _
  114.                        As AcadSelectionSet
  115.   'Enable error handling, but just skip the error
  116.   On Error Resume Next
  117.   'Attempt to get the named selection set
  118.   Set GetSS = theDoc.SelectionSets.Item(Name)
  119.   GetSS.Clear 'Clear the selection set of any items
  120.   'If this error occurred, the selection set didn't exist, create it
  121.   If Err.Number = 91 Then Set GetSS = theDoc.SelectionSets.Add(Name)
  122. End Function
  123. 'Change the given attribute in the given block reference
  124. Private Sub ChangeAttrib(ByVal theBlock As AcadBlockReference, _
  125.                          ByVal TagName As String, _
  126.                          ByVal NewText As String)
  127.   Dim myAtts As Variant 'GetAttributes returns an array
  128.   myAtts = theBlock.GetAttributes 'Get the attributes
  129.   
  130.   Dim i As Long 'Declare a counter
  131.   For i = 0 To UBound(myAtts) 'Loop thru all attributes
  132.     With myAtts(i) 'For each attribute
  133.       'If the current attribute is the correct one
  134.       If .TagString = TagName Then
  135.         .TextString = NewText 'change the attributes value
  136.         Exit For 'Exit the loop, we are done
  137.       End If
  138.     End With
  139.   Next i
  140. End Sub
  141. 'Returns all the attributed inserted blocks in a drawings layouts
  142. Private Function GetBlocks(ByVal theDoc As AcadDocument, _
  143.                            ByRef BlockStore As Scripting.Dictionary)
  144.   'Set dictionary's comparison mode to work with text
  145.   BlockStore.CompareMode = TextCompare
  146.   
  147.   Dim aEntity As AcadEntity 'Stores each entity in turn
  148.   Dim aLayout As AcadLayout 'Stores each layout in turn
  149.   Dim aBlkRef As AcadBlockReference 'Stores a block reference
  150.   For Each aLayout In theDoc.Layouts 'Loop thru all the layouts
  151.     'The below condition is for performance, it excludes ModelSpace
  152.     If Not (aLayout.ModelType) Then
  153.       For Each aEntity In aLayout.Block 'Loop thru all entities
  154.         'If the current entity is a block insertion
  155.         If TypeOf aEntity Is AcadBlockReference Then
  156.           Set aBlkRef = aEntity 'Cast the entity into a block ref
  157.           'If the block insertion has attributes
  158.           If aBlkRef.HasAttributes Then
  159.             'Use a procedure to add block to dictionary
  160.             'Need procedure for isolated error handling
  161.             AddBlock BlockStore, aBlkRef.Name, aBlkRef.GetAttributes
  162.           End If
  163.         End If
  164.       Next aEntity
  165.     End If
  166.   Next aLayout
  167. End Function
  168. 'Adds a block name and its attributes to a dictionary
  169. Private Sub AddBlock(ByRef BlockStore As Scripting.Dictionary, _
  170.                      ByVal Name As String, _
  171.                      ByVal Attribs As Variant)
  172.   'Enable error handling, but just skip the error
  173.   On Error Resume Next
  174.   'Attempt to add block name and its attributes to the dictionary
  175.   'If the block name already exists in the dictionary,
  176.   'an error occurs. So this procedure just skips the duplicate.
  177.   BlockStore.Add Name, Attribs
  178. End Sub
  179. 'Display an open dialog, adds selected files to an array
  180. Private Function GetFiles() As Variant
  181.   'Stores the object created by the CommonDialog class
  182.     Dim myOpen As CommonDialogProject.CommonDialog
  183.   Set myOpen = CommonDialogProject.Init 'Create the object
  184.   
  185.   myOpen.DialogTitle = "Select drawings" 'Change the title
  186.   myOpen.Filter = "AutoCAD Drawing files (*.dwg)|*.dwg|" & _
  187.                           "AutoCAD Drawing template files (*.dwt)|*.dwt"
  188.     myOpen.DefaultExt = "dwg"
  189.   'Set flags to limit behavior of the dialog box
  190.   myOpen.Flags = OFN_ALLOWMULTISELECT + _
  191.                  OFN_EXPLORER + _
  192.                  OFN_FILEMUSTEXIST + _
  193.                  OFN_HIDEREADONLY + _
  194.                  OFN_PATHMUSTEXIST
  195.    myOpen.InitDir = FindPath("path\to\files\no\leading\or\trailing\backslashes")
  196.    myOpen.MaxFileSize = 2048 'Increase buffer of filenames
  197.   
  198.   Dim success As Long 'Stores the return value from CommonDialog
  199.   success = myOpen.ShowOpen 'Display the open dialog box
  200.   'If the dialog was not cancelled get array of filenames
  201.   If success > 0 Then GetFiles = myOpen.ParseFileNames
  202. End Function
  203. Private Function FindPath(ByVal path As String) As String
  204. Dim X As Integer
  205. For X = 67 To 69
  206.    rVal = Dir(Chr(X) & ":" & path & "\*.*")
  207.    If rVal  "" Then
  208.      FindPath = Chr(X) & ":" & path
  209.      X = 70
  210.    Else
  211.      FindPath = "C:"
  212.    End If
  213. Next X
  214. End Function
回复

使用道具 举报

154

主题

1274

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1936
发表于 2007-3-22 11:00:45 | 显示全部楼层
如果您更改每个计算机上图形文件夹的路径,那么您所拥有的应该可以使用。减去图形名称,再减去驱动器号……因此,如果图形的路径是:;C: “\程序文件\存储数据\图纸”
您可以使用
  1. MyOpen.InitDir = FindPath ("Program Files\Stored Data\Drawings")
然后它将返回;C: \"作为初始文件夹或;[驱动器号]:\程序文件\存储数据\图纸“;作为初始文件夹,这更有意义吗?
回复

使用道具 举报

48

主题

277

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
481
发表于 2007-3-22 11:32:15 | 显示全部楼层
Keith路径的唯一区别是驱动器号。文件夹是一样的,所以我试着把它放在myOpen上。InitDir=FindPath(“\Drawings”)
当我运行它时,我收到以下消息:
编译错误
变量未定义
,并且rVal突出显示
当您说我需要更改每台计算机上图形文件夹的路径时,您的意思是什么?这一点是为了让它找到图形文件夹,而不管它位于哪个驱动器上?
回复

使用道具 举报

154

主题

1274

帖子

8

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1936
发表于 2007-3-22 11:37:54 | 显示全部楼层
添加
  1. Dim rVal As String
到;findpath“;将Dim X后面的函数作为整数行,然后将函数调用更改为
  1. myOpen.InitDir = FindPath("Drawings")
如果你看一下我提供的例子,你会发现我说过要去掉开始反斜杠和结束反斜杠
回复

使用道具 举报

48

主题

277

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
481
发表于 2007-3-22 11:44:39 | 显示全部楼层
啊,是的,成功了。我在上次发布后删除了反斜杠。我将不得不去女孩的电脑谁有她的画在不同的驱动器和测试它。谢谢大家,这是一次很好的学习经历。本人'我会告诉你事情的进展
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-7-7 14:35 , Processed in 1.895338 second(s), 60 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表