topic Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!) in VBA Forum

VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 13:35:20 GMT

Need~
I need to search through several hundred drawings and check to make sure the customer is "Dilling Mechanical" not "Corporate Construction"

Tried/Problem~
I tried using SRXTEXT and the script fails if the Title Block is correct and there are no replacements req'd. I also tried using a single command (to no avail) in SRXTEXT as: (srxTEXT "Substring" "CORPORATE CONSTRUCTION" "DILLING MECHANICAL" "All") I get ; error: no function definition: SRXTEXT

Also Tried~
I found this VBA code on a post yesterday and I tried to alter the code to work on my situation. I stepped through the code and the text that I'm trying to change doesn't get selected in the code. It is in MSPACE. How do we fix that?

Attached~
my VBA code attempt from post yesterday
one of the sheets that need changed.

Test for success-
run a script, a snippet of code (VBA), or whatever twice through this dwg and the first time it changes the text. 'CORPORATE CONSTRUCTION' to 'DILLING MECHANICAL' and the second time runs through with out errors using the EXACT same input. Some sheets need changed and some don't.

Side Note/Question~
How would I use a button to run a script. Say the script is:
C:\Scripts\runme.scr what is the command of the button?

THANKS THANK YOU MUCH OBLIGED!!!!!!

Thanks,
MSR

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 13:39:28 GMT

Here is the attachment....

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 15:34:59 GMT

You haven't specified what version this dwg is... I've tried to open it in 2006 to no avail so I assume 2007?

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 15:45:32 GMT

Sorry -
It is 2007.

I'm attaching a 2004 version.

Thx!

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

ska67can — Wed, 29 Nov 2006 15:51:00 GMT

wrote code to do similar task recently. i'll look at it tonight to see if i can modify it.

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 15:53:20 GMT

The problem you are having is that the text you wish to change is contained within a title block, not as a text string, and is in layout, not model space. I'll have a look when I get home 🐵

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 15:53:58 GMT

Attached DVB would not work for you because of you
tryed to change attributes neither text

See my examle how you can to do it
(one of many ways though)

Option Explicit

Sub Ch_TitleBlock_Att()

Dim oLayout As AcadLayout, _
oBlock As AcadBlock, _
oEnt As AcadEntity, _
blkRef As AcadBlockReference, _
attObj As AcadAttributeReference, _
attData() As AcadObject, _
newVal As String, _
bName As String, _
fType(2) As Integer, _
fData(2) As Variant, _
dxfType, _
dxfData, _
aTag As String, _
k As Integer

bName = InputBox("Enter Block Name To Change :", "Modify Tiltle Block", "TITLE_BLOCK")
aTag = InputBox("Enter Attribute Name To Change :", "Modify Tiltle Block", "PROJNAME")
newVal = InputBox("Enter New Attibute Value: ", "Modify Tiltle Block")

For Each oLayout In ThisDrawing.Layouts
For Each oEnt In oLayout.Block
If TypeOf oEnt Is AcadBlockReference Then
Set blkRef = oEnt
If blkRef.Name = bName Then
attData = blkRef.GetAttributes
For k = 0 To UBound(attData)
Set attObj = attData(k)
If attObj.TagString = aTag Then
attObj.TextString = newVal
attObj.Update
blkRef.Update
Exit For
End If

Next k
End If
End If
Next oEnt
Next oLayout

End Sub

Fatty

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 18:43:44 GMT

Thanks -

The only problem that I see is that I can't use a script to completely automate with the message boxes popping up. I like to watch the computer work; not my fingers!!! LOL

How about this?---
-- This would allow me to pass the parameters through the script into the VBA and still make the changes with IF statements?? What would my command line be for this (assuming that it works?)

Also how do you program a button to do mulitline commands?
What about the pgp file. I want ZE to mean Zoom Extents but I haven't figured out how to program the pgp file to do that.
THANKS A BUNCH

Option Explicit

Sub Ch_TitleBlock_Att (bName as String, aTag as String, newVal as String)

Dim oLayout As AcadLayout, _
oBlock As AcadBlock, _
oEnt As AcadEntity, _
blkRef As AcadBlockReference, _
attObj As AcadAttributeReference, _
attData() As AcadObject, _
newVal As String, _
bName As String, _
fType(2) As Integer, _
fData(2) As Variant, _
dxfType, _
dxfData, _
aTag As String, _
k As Integer

For Each oLayout In ThisDrawing.Layouts
For Each oEnt In oLayout.Block

If TypeOf oEnt Is AcadBlockReference Then
Set blkRef = oEnt
If blkRef.Name = bName Then
attData = blkRef.GetAttributes
For k = 0 To UBound(attData)
Set attObj = attData(k)
If attObj.TagString = aTag Then
attObj.TextString = newVal
attObj.Update
blkRef.Update
Exit For
End If

Next k
End If
End If
Next oEnt
Next oLayout

End Sub

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Wed, 29 Nov 2006 22:47:41 GMT

I agree, let the machine works, I like to drink a beer instead 🙂
Here is my old one, slightly edited
Put this unzipped in any of your "Support File Search Path" folders

Macro on button:

^C^C^P_-vbarun;ch-att-val.dvb!RunMe

Tested with button on A2005 only

Fatty

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Fri, 01 Dec 2006 18:38:01 GMT

Wow - That is pretty amazing. I am very familiar with VBA in Excel and I am just learning VBA in cad. I really appreciate what you've done. However it still doesn't really solve my problem. I have a script generator that has two parts. A file selection part and a script part. I need a tool (VBA / Lisp) etc that will take a command line and change the any text (block att, mtext, etc...) given a find (textA) and replace with (textB). SRXTEXT works great as long as (textA) exist; the problem comes when the dwg is correct as is and SRXTEXT doesn't find an instance of (textA)
I have hundreds of dwgs to check, not all of them need corrected. This has to easy for you to do. I'm just not able to clearly state the problem maybe.

I have 100's of drawings and in some of them the customer is labled as 'CORPORATE CONSTRUCTION'. When this is the case 'CORPORATE CONSTRUCTION' needs to be replaced with 'DILLING MECHANICAL'. The problem is complicated by the fact the some of title blocks have been exploded and some of them don't need fixed. So one set of commands will be applied to every dwg and I can just watch it do its thing - and enjoy a drink as you put it!!! I hope that is more clear. Thanks for all of your help.

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Fri, 01 Dec 2006 19:25:12 GMT

Hi Mike
Sorry my stupidity
I read your message 5 times but have not understand your task enough
Let me explain it again
Thus you have some blocks in the drawing and some exploded blocks there
In the first case you need to change attribute values, in the
second case you need change text/mtext you found
And two these tasks I must to union and solve in one programm
Let me know if I am wrong
Or better yet attach this bad drawing with some good and bad (exploded) blocks 🙂

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Fri, 01 Dec 2006 20:26:16 GMT

I think we're on the same page now!!

What I need the code to do is make sure that the customer (whether in block form or not) is 'DILLING MECHANICAL' not 'CORPORATE CONSTRUCTION' without user input. This will allow me use a script generator to apply the code to all of the dwgs.

I'm attaching 4 dwgs. One for each possible case. Remember there are litterally hundreds of these. I have a script generator that I can use to write the script to do the following:

1)open dwg
2) apply code you provide
3) save & close dwg
--> repeat for next dwg until complete.

Each drawing will be one of the following catagories. I have attached a typical exp. for each type.

1) Title block is intact and is correct as is - no action req'd but code still runs through without errors or user input req'd.
2) Title block is intact but needs 'CORPORATE CONSTRUCTION' changed to 'DILLING MECHANICAL' This is the 'CUSTOMER att of the TITLE_BLOCK.
3) Title block has been exploded is ok as is - no action req'd but code must still run through as before..
4) Title block has been exploded but needs text 'CORPORATE CONSTRUCTION' changed to 'DILLING MECHANICAL'

Thanks!
MSR

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Fri, 01 Dec 2006 21:24:01 GMT

Okay, I'll work with this tomorrow
Now is clear enough for me
:)

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Fri, 01 Dec 2006 23:54:22 GMT

Hello MSR
Here is framework only
This will change text objects only, if you will not
found some mistakes here I will be go further with
block change part
Make sure your current version ObjectDBX library
in Tools->Reference
Tested on A2005 only

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

ska67can — Sat, 02 Dec 2006 00:11:40 GMT

Try this. You'll have to add a reference to excel & mso object library. Run macro, select folder where drawings are located and go have a drink. Takes care of both blocks and plain text.

code:
Option Explicit
Option Compare Text

Public oExcel As excel.Application
Public dCount As Integer
Public foldSel As Variant
Public foldName As String
Public fsObj As Variant
Public foldObj As Variant
Public fileObj As Variant
Public fName As Variant
Public sCount As Integer
Public mResponse As Integer
Public fStr As String
Public sText As String
Public sStr As Long
Public fCount As Integer
Public intI As Integer
Public bRefVar As Variant
Public blockObj As AcadBlock
Public bRefObj As AcadBlockReference
Public textObj As AcadText
Public entObj As AcadEntity

Public Sub ReplaceText()

Set oExcel = excel.Application
'Save & Close all Active Drawings
If AutoCAD.Application.Documents.Count <> 0 Then
For dCount = 0 To AutoCAD.Application.Documents.Count - 1
AutoCAD.ActiveDocument.Save
AutoCAD.ActiveDocument.Close
Next
End If

' Open the Folder Dialog
Do While sCount = 0
Set foldSel = oExcel.FileDialog(msoFileDialogFolderPicker)
With foldSel
.Title = "Choose Folder Containing drawing Files to be Updated"
'If Folder Selected
If .Show = -1 Then
foldName = CStr(.SelectedItems.Item(1))
Else 'User Cancelled-Exit Macro
MsgBox "No selection made. Program Cancelled."
oExcel.Quit
Exit Sub
End If
End With

Set fsObj = CreateObject("Scripting.FileSystemObject")
Set foldObj = fsObj.GetFolder(foldName)
Set fileObj = foldObj.Files

'Determine if Folder Contains Dwg Files
sCount = CountFiles(foldName) 'Calls the Function
If sCount = 0 Then 'No Dwg Files Found in Selected Folder
'Give User Choice to Retry or Quit
mResponse = MsgBox(foldName & Chr(13) & _
" Does Not Contain Drawing Files", vbRetryCancel)
If mResponse = 2 Then 'User Cancelled-Exit Macro
MsgBox "Program Cancelled."
oExcel.Quit
Exit Sub
End If
End If
Loop

'Check if Subfolder Exists
If CheckDir(foldName & "\Updated Drawings") Then
MsgBox foldName & " Already Updated"
Exit Sub
End If
'Create SubFolder for Updated Dwgs
MkDir foldName & "\Updated Drawings"

'Open Each Drawing in Selected Folder
For Each fName In fileObj

If Right(fName.Name, 3) = "dwg" Then
fStr = fName.Name
End If

AutoCAD.Application.Documents.Open (foldName & "\" & fStr)

For Each entObj In ThisDrawing.PaperSpace
If entObj.ObjectName = "AcDbBlockReference" Then
Set bRefObj = entObj
With ThisDrawing.Utility
If bRefObj.HasAttributes Then
bRefVar = bRefObj.GetAttributes
For intI = LBound(bRefVar) To UBound(bRefVar)
sText = bRefVar(intI).TextString
If sText = "CORPORATE CONSTRUCTION" Then
bRefVar(intI).TextString = "DILLING MECHANICAL"
End If
Next
End If
End With
End If
Next

For Each entObj In ThisDrawing.PaperSpace
If entObj.ObjectName = "AcDbText" Then
If entObj.TextString = "CORPORATE CONSTRUCTION" Then
entObj.TextString = "DILLING MECHANICAL"
End If
End If
Next

sStr = Len(AutoCAD.ActiveDocument.Name)
fStr = Left(AutoCAD.ActiveDocument.Name, sStr - 4)

'Rename Dwg & Save in Different Folder
AutoCAD.ActiveDocument.SaveAs (foldName & "\Updated Drawings\" & fStr & " UPDATED.dwg")
'Close Dwg
AutoCAD.ActiveDocument.Close
Next

oExcel.Quit

fCount = CountFiles(foldName & "\Updated Drawings")
MsgBox sCount & " Files Selected" & Chr(13) & fCount & " Files Updated"

End Sub

Function CountFiles(tgtDir As String) As Integer

Dim fName As String
fName = Dir(tgtDir & "\*.dwg")
On Error GoTo 0
'loop through all files in the directory and increment the function's value
Do While fName <> ""
If fName <> "." And fName <> ".." Then
CountFiles = CountFiles + 1
End If
' Get next entry.
fName = Dir()
Loop

End Function

Function CheckDir(newDir As String) As Boolean

If Dir(newDir, vbDirectory) <> "" Then CheckDir = True

End Function

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Sat, 02 Dec 2006 10:19:29 GMT

Hi MSR,
I have to added the part that allow to change blocks etc also
This will work with default values, feel free to change
to your suit
Try edited version let me know if something wrong there
Hth

Fatty

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Mon, 04 Dec 2006 13:40:47 GMT

Fatty,

I just got in and had a chance to look at your responses. Before I even load the project I wanted to shout a big THANKS! Im sure that this will work as we got on the same sheet of music. Wish I could buy you a drink now too - you deserve it!!!

I'll load the project here in a little while and let you know that it works great.

Thanks again,
MSR

PS - Does Autodesk pay you for this stuff or are you some kind of CodeAngel?? LOL!!

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Mon, 04 Dec 2006 13:52:43 GMT

Comon, MSR
I am stupid haker only and nothing else, I'm still on the same
level as I was 3 years ago...
No flowers, please
Let me know if something wrong here
Anyway my big thanks for the kindly words

Happy computing,

Cheers 🙂

~'J'~

Re: VBA / Find Replace / Quick Fix for Someone (not me...Please Help!!)

Anonymous — Mon, 04 Dec 2006 18:21:00 GMT

Hey it works great!

I have a two second fix for you. I added text box to the form and tried to set it up so that it updates the dwg being edited.

The code I used is below (nested into your code)
Doesn't update. Is this because of the DoEvents command?

oDbx.Open DwgName
frmReplace.txtDWG.value = DwgName

For Each oLayout In oDbx.Layouts
For Each objFnd In oLayout.Block

That is a really cool app - we'll definitely get lot of use out of it.

Thanks, MSR