TheSwamp
Code Red => VB(A) => Topic started by: TallCoolOne on October 05, 2006, 10:22:06 AM
-
well, I'm trying to change out old revision blocks with new rev blocks, i have the code to change out the old rev blocks with the new ones & and all the attributes from the old blocks. my problem is that the new blocks are .838923 taller than the old rev blocks and i cant figure out how to make the new rev blocks move up that total for each block on the drawing. there are anywhere from 1 to 10 rev blocks on each drawing. the first one inserts fine but the rest do not move up the required distance
-
You need to do something like this:
For n = 1 to NumberOfRevs
If Not n = 1 Then
yinsert = yinsert + ((n - 1) * .838923)
End If
Next n
-
well, I'm trying to change out old revision blocks with new rev blocks, i have the code to change out the old rev blocks with the new ones & and all the attributes from the old blocks. my problem is that the new blocks are .838923 taller than the old rev blocks and i cant figure out how to make the new rev blocks move up that total for each block on the drawing. there are anywhere from 1 to 10 rev blocks on each drawing. the first one inserts fine but the rest do not move up the required distance
Option Explicit
Public objOldBlk As AcadBlockReference
Public NewBlkName As String
Public objOldAttRef As AcadAttributeReference
Public InsertPt(0 To 2) As Double
Public xScale As Double
Public yScale As Double
Public zScale As Double
Public Rot As Double
Public intOldCnt As Integer
Public varOldAtt As Variant
Public arOldBlkNames(0) As String
Public objBlk As AcadBlock
Public BName As Variant
Public att(0 To 15) As String
Public objNewBlk As Variant
Public intCnt As Double
Public Sub revblocks()
Dim intRevCnt As Integer
intRevCnt = ThisDrawing.Utility.GetInteger("Enter Number of Rev's to Change: ")
intCnt = 0
While intCnt <= intRevCnt
OldBlk
Wend
End Sub
Public Sub OldBlk() 'gets old block and attribute information
Dim objAcadSSet As AcadSelectionSet
Dim intTextCodes(0) As Integer
Dim varCodeValues(0) As Variant
Dim VerBlock As AcadBlock
arOldBlkNames(0) = "REVBLK1"
On Error Resume Next
Call DeleteSelSet 'delete old selection set if existing
Set objAcadSSet = ThisDrawing.SelectionSets.Add("sSet2")
intTextCodes(0) = 0 'set code for entities
varCodeValues(0) = "INSERT" 'set entity type to filter
objAcadSSet.SelectOnScreen intTextCodes, varCodeValues 'create set
For Each objOldBlk In objAcadSSet
BName = UCase(objOldBlk.Name)
Select Case BName
Case arOldBlkNames(0) 'REVBLK1
InsertPt(0) = objOldBlk.InsertionPoint(0)
InsertPt(1) = objOldBlk.InsertionPoint(1)
InsertPt(2) = objOldBlk.InsertionPoint(2)
xScale = objOldBlk.XScaleFactor
yScale = objOldBlk.YScaleFactor
zScale = objOldBlk.ZScaleFactor
Rot = objOldBlk.Rotation
If objOldBlk.HasAttributes Then
varOldAtt = objOldBlk.GetAttributes 'get block attributes
End If
For intOldCnt = LBound(varOldAtt) To UBound(varOldAtt)
Set objOldAttRef = varOldAtt(intOldCnt)
Next intOldCnt
NewBlkName = "revblk3.dwg"
NewBlk
End Select
If BName = "REVBLK3" Then
MsgBox "This Rev Block does not need to be updated. ", vbOKOnly
End If
Next objOldBlk
End Sub
Public Sub NewBlk() 'replace old block with new block
Dim objNewBlk As AcadBlockReference
Dim objNewAttRef As AcadAttributeReference
Dim intNewCnt As Integer
Dim varNewAtt As Variant
Dim strLength As Long
Dim NewRevArea As String
Dim varTempAtt1 As Variant
Dim varTempAtt2 As Variant
Dim intTotal As Double
intTotal = 0.83892 * intCnt
If InsertPt(1) <= (yScale * 2.6875) Then
InsertPt(1) = InsertPt(1)
Else
InsertPt(1) = InsertPt(1) + ((intTotal) * intCnt)
End If
intCnt = intCnt + 1
Select Case BName
Case arOldBlkNames(0) 'REVBLK1
Set objNewBlk = ThisDrawing.ModelSpace.InsertBlock(InsertPt, NewBlkName, xScale, yScale, zScale, Rot) 'insert new RevBlock
varNewAtt = objNewBlk.GetAttributes 'get attributes
For intOldCnt = LBound(varOldAtt) To UBound(varOldAtt)
For intNewCnt = LBound(varNewAtt) To UBound(varNewAtt)
If varOldAtt(intOldCnt).TagString = "REV" Then
If varNewAtt(intNewCnt).TagString = "NO." Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "DESCRIPTION_LINE_1" Then
If varNewAtt(intNewCnt).TagString = "DSCR0" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "DESCRIPTION_LINE_2" Then
If varNewAtt(intNewCnt).TagString = "DSCR1" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "TECH" Then
If varNewAtt(intNewCnt).TagString = "TECH" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "APPR" Then
If varNewAtt(intNewCnt).TagString = "APP1" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "DATE" Then
If varNewAtt(intNewCnt).TagString = "MYR" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "STB1" Then
If varNewAtt(intNewCnt).TagString = "NO." Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "STB3" Then
If varNewAtt(intNewCnt).TagString = "DSCR0" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "STB2" Then
If varNewAtt(intNewCnt).TagString = "DSCR1" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "STB4" Then
If varNewAtt(intNewCnt).TagString = "TECH" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "STB5" Then
If varNewAtt(intNewCnt).TagString = "APP1" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
If varOldAtt(intOldCnt).TagString = "STB6" Then
If varNewAtt(intNewCnt).TagString = "MYR" Then
varNewAtt(intNewCnt).TextString = varOldAtt(intOldCnt).TextString
End If
End If
Next
Next
End Select
objNewBlk.Update
objOldBlk.Delete
'ThisDrawing.Application.ZoomExtents
End Sub
Public Sub DeleteSelSet() 'delete selection set
Dim gobjAcadSelectionSets As AcadSelectionSets
Dim objAcadSSet As AcadSelectionSet
Dim strSelSetName As String
Set gobjAcadSelectionSets = ThisDrawing.SelectionSets
strSelSetName = "sSet2"
For Each objAcadSSet In gobjAcadSelectionSets
If objAcadSSet.Name = strSelSetName Then
objAcadSSet.Delete
Exit Sub
End If
Next objAcadSSet
End Sub
-
You may have to post a sample dwg to get help on this one, TallCool.
intTotal = 0.83892 * intCnt
If InsertPt(1) <= (yScale * 2.6875) Then ''''''''''How is the insertionpt related to the scale
InsertPt(1) = InsertPt(1)
Else
InsertPt(1) = InsertPt(1) + ((intTotal) * intCnt) '''''''''I don't get this looks like intCnt*intcnt
End If
intCnt = intCnt + 1
Plus private is usually safer than public dims
-
You may have to post a sample dwg to get help on this one, TallCool.
intTotal = 0.83892 * intCnt
If InsertPt(1) <= (yScale * 2.6875) Then ''''''''''How is the insertionpt related to the scale
InsertPt(1) = InsertPt(1)
Else
InsertPt(1) = InsertPt(1) + ((intTotal) * intCnt) '''''''''I don't get this looks like intCnt*intcnt
End If
intCnt = intCnt + 1
Plus private is usually safer than public dims
Hey Bryco,
thanks for pointing me to the spot that fixed it
nsertPt(1) = InsertPt(1) + ((intTotal) * intCnt) '''''''''I don't get this looks like
i was mutiplying intCnt to many times .... it works thanks again
-
This may be of interest to you.
http://www.theswamp.org/index.php?topic=12901.0