VBA Customized Title block take 2

[Anonymous]

Hello again everyone,
I'm in need of some expertise. I'm still working on my Titleblock editing routine that I posted earlier in the year. See http://discussion.autodesk.com/thread.jspa?messageID=5460292. I'm trying to add a control to my editor that allows the user to import attribute values that were extracted from another drawing, this fuctionality is similar to "Importing Attributes" command in Express tools. I have code in the routine that I found that allows me to browse to the file location and select the a file to be imported. I 've been fumbling with this for days. I don't know how to get the info out of the file and into the correct textboxes in the form. I think I need to create an array then possibly split the info? Can someone give me a "Baby Step" instructions on what needs to happen First, Second, Third, ...... so on. I've attached the .dwg and .dvb file. Thank You

[Anonymous]

I didn't read all the previous post due to time, but this may give me a better perspective by not doing that and just trying to accomplish your goal.

Looks like you want to do this:
Import titleblock information from an old file and have the titleblock filled out in a new file with the same info.

First question:
In the old files, are the block references consistent in the block name & attribute names?

If so..

Then using the Acad object model, define your two Acad documents with variables so they are easy to access. Or as I do lots of times, I create an new autocad instance and make it invisible.

Open & Access the old drawing.
Access the block reference you are after by name
Access the attribute references within it
Store the values of the attributes in an array (or multiple variable)
Close the old drawing.
Access the new drawing.
Access the new block reference
Access the attributes references
Set the values of the attribute references.
(Or set the textboxes of your dialog to have the attribute values if that's what you are doing.)
Finished.

I can write some code for you if you need, doesn't seem that
difficult though.

Good luck.

I did something similar, but here's what I did. I got a list from accounting of all our projects, put it all in an access database and coordinated with IT about linking my database to thier data as it's input for project authorization, created a form in AutoCAD VBA to look up the projects information out of my access DB, that then it fills out my dialog box for the titleblock information. BUT...
Instead of setting attribute values, my standard titleblocks already have attributes with defualt values of fields text that points to these custom drawing properties (DWGPROPS). So my userform, when I press 'OK', it sets these custom drawing properties' values. When ever I pull in a titleblock, any size, as many as I want, they are already filled out. I do also have a feature to actually write the text into the attribute values (fields scare some users apparently) because I named the custom dwg properties (textboxes, comboboxes, etc.) the same as the attribute tags (no spaces hence the underscores) so I can use my array in the program in 2 different ways at the choice of the users.

'~~~~Heres some code for setting DWGPROPS:
'~~~~this is the code behind the button
'~~~~ on the userform to that then
'~~~~calls a function called writefields
Private Sub btnWriteFields_Click()
writeFields
Me.lblProgress.Caption = "Fields have been written to the file."
Me.btnWriteFields.Enabled = False
Me.lbltest.Caption = "1"
End Sub

'~~~writefields function, calls mkListAry function
'~~~also calls custFldAry function & ChgFld function
Private Function writeFields()
Dim chkForErr As Boolean
Dim i As Integer
oldEval = ThisDrawing.GetVariable("FIELDEVAL")
mkListAry
If custFldAry > "" Then On Error GoTo 0
For i = LBound(fldList) To UBound(fldList)
changeFld ThisDrawing, fldList(i, 0), frmDwgProp.Controls(fldList(i, 1)).Value
Next i
ThisDrawing.SetVariable "FIELDEVAL", 31
ThisDrawing.Regen (acActiveViewport)
ThisDrawing.SetVariable "FIELDEVAL", oldEval
Me.lbltest.Caption = "1"
End Function

'~~~
Private Function mkListAry()
'array = Field Name, Control Name (textboxes, etc.)
fldList(0, 0) = "Client_Name1": fldList(0, 1) = "tbClientNameA"
fldList(1, 0) = "Client_Name2": fldList(1, 1) = "tbClientNameB"
fldList(2, 0) = "Client_Address1": fldList(2, 1) = "tbClientAddress"
fldList(3, 0) = "Client_City": fldList(3, 1) = "tbClientCity"
fldList(4, 0) = "Client_State": fldList(4, 1) = "tbClientState"
fldList(5, 0) = "Client_Zip": fldList(5, 1) = "tbClientZip"
fldList(6, 0) = "Project_Name1": fldList(6, 1) = "tbProjectNameA"
fldList(7, 0) = "Project_Name2": fldList(7, 1) = "tbProjectNameB"
fldList(8, 0) = "Project_Address1": fldList(8, 1) = "tbProjectAddress"
fldList(9, 0) = "Project_City": fldList(9, 1) = "tbProjectCity"
fldList(10, 0) = "Project_State": fldList(10, 1) = "tbProjectState"
fldList(11, 0) = "Project_Zip": fldList(11, 1) = "tbProjectZip"
fldList(12, 0) = "UEI_Project_Number": fldList(12, 1) = "tbProjectNumber"
fldList(13, 0) = "Discipline": fldList(13, 1) = "cboDiscipline"
fldList(14, 0) = "Plan_Signer": fldList(14, 1) = "tbPlanSigner"
fldList(15, 0) = "Signature_Date": fldList(15, 1) = "tbSigDate"
fldList(16, 0) = "Lic_or_Reg": fldList(16, 1) = "cboLicReg"
fldList(17, 0) = "Lic-Reg_Number": fldList(17, 1) = "tbLicRegNumber"
fldList(18, 0) = "Start_Date": fldList(18, 1) = "tbDwgStart"
fldList(19, 0) = "Current_Rev_Number": fldList(19, 1) = "tbCurrentRevNum"
fldList(20, 0) = "Drawn_By": fldList(20, 1) = "tbDrawnBy"
fldList(21, 0) = "Checked_By": fldList(21, 1) = "tbCheckedBy"
fldList(22, 0) = "Approved_By": fldList(22, 1) = "tbApprovedBy"
fldList(23, 0) = "Sheet_Count": fldList(23, 1) = "tbSheetCount"
End Function

''''function custFldAry - returns a comma delimted string of
'all the custom field names for the current drawing and thier values
'in that order. It also returns just a field last optionally.
''''function chngFld will change a fields value or alternatively
'create the given field name and set the value if it does not already exist

Function custFldAry(Optional NoVals As Boolean) As String
Dim docInfo As AcadSummaryInfo
Set docInfo = ThisDrawing.SummaryInfo
Dim fName As String
Dim fVal As String
Dim fResult As String
Dim i As Integer
For i = 0 To (docInfo.NumCustomInfo - 1)
docInfo.GetCustomByIndex i, fName, fVal
If justFields = False Then fName = fName & "," & fVal
If i = docInfo.NumCustomInfo - 1 Then
fResult = fResult & "," & fName
Else
If fResult = "" Then
fResult = fName
Else
fResult = fResult & "," & fName
End If
End If
Next i
If Left(fResult, 1) = "," Then fResult = Mid(fResult, 2)
custFldAry = fResult
End Function

Function chngFld(fldName As String, newVal As String)
On Error GoTo bumDeal
Dim custProps As AcadSummaryInfo
Set custProps = ThisDrawing.SummaryInfo
If InStr(1, custFldAry(True), fldName) < 1 Then GoTo createIt
custProps.SetCustomByKey fldName, newVal
Set custProps = Nothing
Exit Function
createIt:
custProps.AddCustomInfo fldName, newVal
Set custProps = Nothing
Exit Function
bumDeal:
Set custProps = Nothing
End Function
'~~~~end code

Hopefully I didn't snip that up too much.
Enjoy & Good Luck. null

[Anonymous]

Here is a program that will
1. copy block attribute information to a text file
2. read the text file and past the information to a block with attribute.
(it works with the attribute tag)


Option Explicit

Public Sub CopyAttributes()
Dim blockref As AcadBlockReference
Dim returnObj As AcadObject
Dim basePnt As Variant
Dim sname As String

On Error GoTo MYFix

Call ThisDrawing.Utility.GetEntity(returnObj, basePnt, "Select A Block")

If UCase(returnObj.ObjectName) = UCase("AcDbBlockReference") Then
Set blockref = returnObj
If blockref.HasAttributes = True Then
Call GetAttribs(blockref)
Else
Call MsgBox("No Attributes Found", vbExclamation, "Error")
End If
Else
Call MsgBox("Next Time Pick a Block", vbExclamation, "Error")
End If

Exit Sub

MYFix:
Err = 0

End Sub

Public Sub PasteAttributes()
Dim blockref As AcadBlockReference
Dim returnObj As AcadObject
Dim basePnt As Variant
Dim sname As String

On Error GoTo MYFix

Call ThisDrawing.Utility.GetEntity(returnObj, basePnt, "Select A Block")

If UCase(returnObj.ObjectName) = UCase("AcDbBlockReference") Then
Set blockref = returnObj
If blockref.HasAttributes = True Then
Call PasteAttribs(blockref)
Else
Call MsgBox("No Attributes Found", vbExclamation, "Error")
End If
Else
Call MsgBox("Next Time Pick a Block", vbExclamation, "Error")
End If

Exit Sub

MYFix:
Err = 0
End Sub

Private Sub GetAttribs(blockref As AcadBlockReference)
Dim attribs As Variant
Dim i As Integer
Dim sTag As String
Dim sValue As String
Dim sTxtFile As String
Dim VntInfo As Variant

On Error GoTo MYFix
'========================================================
sTxtFile = ThisDrawing.Application.Path & "\CopyPastAtt.txt"
attribs = blockref.GetAttributes

ReDim VntInfo(UBound(attribs))
For i = LBound(attribs) To UBound(attribs)
sTag = Trim(attribs(i).TagString)
sValue = attribs(i).TextString
VntInfo(i) = sTag & "|" & sValue
Next i

Call TextFileOpen(sTxtFile, "Block Name = " & blockref.Name)
For i = LBound(VntInfo) To UBound(VntInfo)
Call TextFileAppend(sTxtFile, CStr(VntInfo(i)))
Next i

Exit Sub

MYFix:
Err = 0
End Sub

Private Sub PasteAttribs(blockref As AcadBlockReference)
Dim attribs As Variant
Dim i As Integer
Dim k As Integer
Dim sTag As String
Dim sValue As String
Dim VntValue As Variant
Dim sTxtFile As String
Dim VntInfo As Variant

On Error GoTo MYFix
'========================================================
sTxtFile = ThisDrawing.Application.Path & "\CopyPastAtt.txt"
attribs = blockref.GetAttributes

VntInfo = TextFileData(sTxtFile)
If UBound(VntInfo) > 1 Then
For i = 2 To UBound(VntInfo)
VntValue = StringValuesSeperated(VntInfo(i), "|")
If UBound(VntValue) = 1 Then
sTag = VntValue(0)
sValue = VntValue(1)

For k = LBound(attribs) To UBound(attribs)
If Trim(attribs(k).TagString) = sTag Then
attribs(k).TextString = sValue
Exit For
End If
Next k
End If
Next i
End If

blockref.Update

Exit Sub

MYFix:
Err = 0
End Sub


''''code for text files

Public Function TextFileExist(sFileName As String) As Boolean
If Dir(sFileName, vbDirectory) <> "" Then
TextFileExist = True
Else
TextFileExist = False
End If
End Function

Public Sub TextFileOpen(sFileName As String, sString As String)
Open sFileName For Output As #1
Print #1, sString
Close #1
End Sub

Public Sub TextFileAppend(sFileName As String, sString As String, Optional bLastLine As Boolean)
Open sFileName For Append As #1
'
If bLastLine = True Then
Print #1, sString, ;
Else
Print #1, sString
End If
'
Close #1
End Sub

Public Function TextFileData(sFileName As String, Optional sKeyWord As String) As Variant
Dim s As String
Dim sLine As String
Dim sArray() As String
ReDim sArray(0)
Dim i As Integer

Open sFileName For Input As #1

Do Until EOF(1)
Line Input #1, s
If Trim(sKeyWord) = "" Then
ReDim Preserve sArray(UBound(sArray) + 1)
sArray(UBound(sArray)) = s
Else
If UCase(s) Like UCase(sKeyWord) Then
sLine = s
Exit Do
End If
End If
Loop

Close #1

If sKeyWord = "" Then
TextFileData = sArray
Else
TextFileData = sLine
End If

End Function

Public Function TextFileDataReplace(sFileName As String, sOldString As String, sNewString As String) As Boolean
Dim s As String
Dim i As Integer
Dim sArray() As String
Dim sString As String

TextFileDataReplace = False
On Error GoTo myerrorHand

Open sFileName For Input As #1
Do Until EOF(1)
Line Input #1, s
If sString = "" Then
ReDim sArray(0)
sString = s
sArray(UBound(sArray)) = sString
Else
ReDim Preserve sArray(UBound(sArray) + 1)
sString = s
If UCase(sString) Like UCase(sOldString) Then
sString = sNewString
End If
sArray(UBound(sArray)) = sString
End If
Loop
Close #1
'
Open sFileName For Output As #1
For i = 0 To UBound(sArray)
Print #1, sArray(i)
Next i
Close #1

TextFileDataReplace = True
myerrorHand:
Err = 0
End Function

Public Function PullStringApart(VntString As Variant, sSeparator As String) As Variant

Dim VntInfo() As Variant
Dim sLeftOver As String
Dim i As Integer
Dim k As Integer
Dim bDone As Boolean

ReDim VntInfo(0)
k = Len(sSeparator)
'
VntInfo(0) = ""
'
sLeftOver = Trim(VntString)
'
Do Until bDone = True
If Trim(VntInfo(UBound(VntInfo))) <> "" Then
ReDim Preserve VntInfo(UBound(VntInfo) + 1)
End If

i = InStr(1, sLeftOver, sSeparator)

If i = 0 Then
If Trim(sLeftOver) <> "" Then
VntInfo(UBound(VntInfo)) = Trim(sLeftOver)
Else
ReDim Preserve VntInfo(UBound(VntInfo) - 1)
End If
bDone = True
Else
VntInfo(UBound(VntInfo)) = Trim(CStr(Mid(sLeftOver, 1, i - k))) '- 1
sLeftOver = Trim(CStr(Mid(sLeftOver, i + k))) ' + 1
End If
Loop

PullStringApart = VntInfo

End Function

Public Function StringReplace(sString As String, sFind As String, sReplace As String, Optional MatchWholeWord As Boolean) As String
'
Dim vntBroken As Variant
Dim i As Integer
Dim s As String
'
vntBroken = StringValuesSeperated(sString, sFind, MatchWholeWord)
For i = 0 To UBound(vntBroken)
If i = 0 Then
s = vntBroken(i)
Else
s = s & sReplace & vntBroken(i)
End If
Next i
StringReplace = s
End Function

Public Function StringValuesSeperated(VntString As Variant, sSeperator As String, Optional MatchWholeWord As Boolean) As Variant
Dim n As Integer
Dim i As Integer
Dim Vnt As Variant
Dim s() As String
Dim nLenSep As Integer
Dim sString As String

sString = VntString
nLenSep = Len(sSeperator)

n = InStr(1, UCase(sString), UCase(sSeperator))
If n <> 0 Then
Vnt = InStrPositions(sString, sSeperator, MatchWholeWord)
Else
ReDim s(0)
s(0) = sString
StringValuesSeperated = s
Exit Function
End If
'
If LBound(Vnt) = 0 And Vnt(0) = 0 Then
ReDim s(0)
s(0) = sString
StringValuesSeperated = s
Exit Function
End If
'
ReDim s(UBound(Vnt) + 1)

For i = LBound(s) To UBound(s)
If i = LBound(s) Then
s(LBound(s)) = Mid(sString, 1, Vnt(LBound(Vnt)) - 1)
ElseIf i = UBound(s) Then
s(UBound(s)) = Mid(sString, Vnt(UBound(Vnt)) + nLenSep)
Else
s(i) = Mid(sString, Vnt(i - 1) + nLenSep, Vnt(i) - Vnt(i - 1) - nLenSep)
End If
Next i

StringValuesSeperated = s

End Function

Private Function InStrPositions(String1 As String, String2 As String, Optional MatchWholeWord As Boolean) As Variant
Dim n As Integer
Dim m As Integer
Dim k As Integer
Dim i As Integer
Dim nPos() As Integer
Dim s As String
Dim s1 As String
Dim s2 As String
Dim nLenString2 As Integer
ReDim nPos(0)
n = InStr(1, UCase(String1), UCase(String2))
If n = 0 Then Exit Function
ReDim nPos(0)
nPos(0) = n
'
If MatchWholeWord = True Then
m = n - 1
k = n + Len(String2)
'
s1 = Mid(String1, m, 1)
s2 = Mid(String1, k, 1)
'
If m <> 0 And k <= Len(String1) Then
If Mid(String1, m, 1) = " " And Mid(String1, k, 1) = " " Then
nPos(UBound(nPos)) = n
Else
nPos(UBound(nPos)) = 0
End If
ElseIf m = 0 And k <= Len(String1) Then
If Mid(String1, k, 1) = " " Then
nPos(UBound(nPos)) = n
Else
nPos(UBound(nPos)) = 0
End If
ElseIf m <> 0 And k > Len(String1) Then
If Mid(String1, m, 1) = " " Then
nPos(UBound(nPos)) = n
Else
nPos(UBound(nPos)) = 0
End If
End If
End If
'
nLenString2 = Len(String2)
'
Do Until n = 0
'
n = InStr(n + 1, UCase(String1), UCase(String2))
'
m = n - 1
k = n + Len(String2)
'
If n = 0 Then Exit Do
If MatchWholeWord = True Then
If m <> 0 And k <= Len(String1) Then
If Mid(String1, m, 1) = " " And Mid(String1, k, 1) = " " Then
If nPos(0) = 0 Then
nPos(UBound(nPos)) = n
Else
ReDim Preserve nPos(UBound(nPos) + 1)
nPos(UBound(nPos)) = n
End If
End If
ElseIf m = 0 And k <= Len(String1) Then
If Mid(String1, k, 1) = " " Then
If nPos(0) = 0 Then
nPos(UBound(nPos)) = n
Else
ReDim Preserve nPos(UBound(nPos) + 1)
nPos(UBound(nPos)) = n
End If
End If
ElseIf m <> 0 And k > Len(String1) Then
If Mid(String1, m, 1) = " " Then
If nPos(0) = 0 Then
nPos(UBound(nPos)) = n
Else
ReDim Preserve nPos(UBound(nPos) + 1)
nPos(UBound(nPos)) = n
End If
End If
End If
Else
ReDim Preserve nPos(UBound(nPos) + 1)
nPos(UBound(nPos)) = n
End If
Loop
'
InStrPositions = nPos
End Function

[Anonymous]

Your question about the attribute info is yes. For the most part the attribute tags are the same in the old file as they are in the new, there's exceptions to the rule. The reason I want to import info from a csv file is two fold. 1) the button can be used as described to import as much of the info as possible to the new border, and 2) the button can import revision info that applies to multiple drawings. I have a Sub that looks at the title block attributes and populates the VBA form. the Sub is "FormAttrEdit" has two Case statements, I was wondering if I might be able to utilize Case TITLE2FORM to repopulate the form with the information I would get from the csv file? The csv file would be opened with the Sub OpenFile.