Hi to everyone;
I have a block which contains visible and unvisible objects and attributes. I need to export custom block properties, which I added to a dynamic block, like in express tool export attribute information.
or it is possible to convert my custom property, which can contains unvisible and visible objects, to attribute value.
Solved! Go to Solution.
Solved by Hallex. Go to Solution.
Try this quick example
Create project with form
Add this code into the form module
Option Explicit Dim selprop As String Dim propArray() ' UserForm1: ' ListBox1 'CommandButton1 'CommandButton2 ' Private Sub CommandButton1_Click() Me.Hide Call GetDynProps Me.Show End Sub Public Sub GetDynProps() ' tested on A2009 only Dim ss As AcadSelectionSet Dim ent As AcadEntity Dim bname As String Dim props() As AcadDynamicBlockReferenceProperty Dim pvalue As Variant Dim blkref As AcadBlockReference With ThisDrawing.SelectionSets While .Count > 0 .Item(0).Delete Wend Set ss = .Add("$DynBlocks$") End With Dim ftype(0 To 1) As Integer Dim fdata(0 To 1) As Variant ftype(0) = 0: ftype(1) = 66 fdata(0) = "INSERT": fdata(1) = 1 ss.SelectOnScreen ftype, fdata If ss.Count = 0 Then MsgBox "No blocks with attributes selected...Exit" Exit Sub End If Set blkref = ss.Item(0) If blkref.IsDynamicBlock Then MsgBox "Ya" Dim i As Integer props = blkref.GetDynamicBlockProperties Dim prop As AcadDynamicBlockReferenceProperty ReDim propArray(UBound(props), 1) For i = LBound(props) To UBound(props) Set prop = props(i) pvalue = prop.Value propArray(i, 0) = prop.PropertyName propArray(i, 1) = CStr(pvalue) Next i End If ListBox1.List = propArray End Sub Private Sub CommandButton2_Click() Dim i For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) = True Then selprop = ListBox1.List(i, 1) Exit For End If Next If selprop = vbNullString Then MsgBox "No item selected in ListBox...Exit" Exit Sub End If Me.Hide Dim varPt, mtx, ctx Dim obj As AcadEntity Dim oAttrib As AcadAttributeReference ThisDrawing.Utility.GetSubEntity obj, varPt, mtx, ctx, vbCr & "Select attribute:" If obj Is Nothing Then MsgBox "Nothing selected, try again...Exit" Exit Sub End If If Not TypeOf obj Is AcadAttributeReference Then MsgBox "You have to select attribute only, try again...Exit" Exit Sub End If Set oAttrib = obj Dim strTag As String strTag = oAttrib.TagString oAttrib.TextString = selprop MsgBox "Done" End End Sub Private Sub UserForm_Initialize() Me.Width = 200 Me.Height = 150 Me.Caption = "Edit Attribute" ListBox1.Left = 6 ListBox1.top = 0 ListBox1.Width = 180 ListBox1.Height = 80 ListBox1.ColumnWidths = "100 pt;60 pt" ListBox1.BoundColumn = 1 ListBox1.ColumnCount = 2 ListBox1.MultiSelect = fmMultiSelectSingle Me.CommandButton1.Caption = "Select block" CommandButton2.Caption = "Select attribute" End Sub
~'J'~
Glad to help
btw you coul be ask me on dwgru as well
Cheers
~'J'~
I try that 😉
I just wondering custum block properties are read only.
If it is possible I want change value by using vba.
Personaly, I don't like to imagine your goal virtually
Better yet, let you upload the sample drawing with this block in this thread
In this case you will be get a help quickier I think...
~'J'~
Sorry for being late,
I am very busy these days.
Here is my sample block, it is simply represent a hydrant in pipe network.
I have many of them in projects, I have a program which calculates hydrant outlet capacity which depends on flow rate and area of irrigation.
Program needs geometric data like km, elevation I have them and there is not a problem but my problem occurs after the calculation I need to rearrange hydrant out let counts. It is easy to do it when these parameters are attributes of a block.
Attributes are easily export and inport to the project but custom properties of a dyn block... I want them too.
Thanks for concerning...
Sub TBS12_BackupRestoreColor()
'Backup Color(ColorColumnFrom, ColorColumnTo,ColorNumber
Dim BackupColorArr() As Variant
Call TBF46_BackupColor(BackupColorArr)
'Clear Color
Dim WS As Worksheet
Set WS = ThisWorkbook.ActiveSheet
Dim TmpRange As Range
Set TmpRange = WS.Range(WS.Cells(5, 6), WS.Cells(77, 36))
TmpRange.Interior.Color = 16777215
Call TBS08_DayoffFillCellColor
'Restore Color
Call TBF47_RestoreColor(BackupColorArr)
End Sub
Sub TBS13_CreatNewSheet()
'New or Edit?
Dim MsgBoxResult As VbMsgBoxResult
Dim MsgPrompt As String
Dim MsgButton As VbMsgBoxStyle
Dim MsgTitle As String
MsgPrompt = "‚Í‚¢F‘S‚ăf[ƒ^‚ð휂µ‚ÄV‹KƒV[ƒg‚ð쬂µ‚Ü‚·B" & vbNewLine & _
"‚¢‚¢‚¦Fƒf[ƒ^‚ð‚»‚Ì‚Ü‚ÜB"
MsgButton = vbYesNoCancel + vbSystemModal
MsgTitle = "ƒV[ƒgV‹KE•ÒW"
MsgBoxResult = MsgBox(MsgPrompt, MsgButton, MsgTitle)
Select Case MsgBoxResult
Case vbYes
Call TBF48_CreatNewSheet("New")
Case vbNo
Call TBF48_CreatNewSheet("Edit")
Case vbCancel
End Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function TBF41_SetFormular(SUS As Worksheet)
Dim RNo As Integer
Dim CNo As Integer
Dim GouKei As Double
Dim GaiChuu As Double
Dim JinIn As Double
Dim TrungBinhNguoi As Variant
Dim TBNguoiThucTe As Variant
Dim TBNguoiMucTieu As Variant
Dim ChuuKi As String
Dim PhanTram As Variant
'If value="" then value=0
For RNo = 5 To 14
Select Case RNo
Case 5, 6, 7, 11, 12, 13
For CNo = 48 To 50
If SUS.Cells(RNo, CNo).Value = "" Then SUS.Cells(RNo, CNo) = 0
Next
End Select
Next
For RNo = 4 To 14
Select Case RNo
Case 4, 10 'chuuki
ChuuKi = SUS.Cells(RNo + 1, 47).Value
SUS.Range(SUS.Cells(RNo, 48), SUS.Cells(RNo, 50)).Value = Left(ChuuKi, 3)
SUS.Cells(RNo, 51).Value = Mid(ChuuKi, 5, 5)
SUS.Cells(RNo, 52).Value = Right(ChuuKi, 5)
Case 5, 6, 7, 11, 12, 13 'Shanai,Kyoto
SUS.Cells(RNo, 51).Value = SUS.Cells(RNo, 48).Value + SUS.Cells(RNo, 49).Value
SUS.Cells(RNo, 52).Value = SUS.Cells(RNo, 48).Value + SUS.Cells(RNo, 49).Value + SUS.Cells(RNo, 50).Value
Case 8, 14 '(xx.x/hito)
For CNo = 48 To 52
GouKei = SUS.Cells(RNo - 3, CNo).Value
GaiChuu = SUS.Cells(RNo - 2, CNo).Value
JinIn = SUS.Cells(RNo - 1, CNo).Value
If JinIn = 0 Then
TrungBinhNguoi = 0
Else
TrungBinhNguoi = (GouKei - GaiChuu) / JinIn
If TrungBinhNguoi >= 100 Then
TrungBinhNguoi = Format(TrungBinhNguoi, "000.0")
Else
TrungBinhNguoi = Format(TrungBinhNguoi, "00.0")
End If
End If
SUS.Cells(RNo, CNo).Value = TrungBinhNguoi
Next
End Select
Next
'%
RNo = 9
For CNo = 48 To 52
TBNguoiThucTe = SUS.Cells(RNo - 1, CNo).Value
TBNguoiMucTieu = SUS.Cells(RNo + 5, CNo).Value
TBNguoiThucTe = CDbl(TBNguoiThucTe)
TBNguoiMucTieu = CDbl(TBNguoiMucTieu)
If TBNguoiMucTieu = 0 Then
PhanTram = 0
Else
PhanTram = TBNguoiThucTe / TBNguoiMucTieu * 100
If PhanTram >= 100 Then
PhanTram = Format(PhanTram, "000.0")
Else
PhanTram = Format(PhanTram, "00.0")
End If
End If
SUS.Cells(RNo, CNo).Value = PhanTram
Next
End Function
Function TBF42_CreatNote(WS As Worksheet, SUS As Worksheet)
'Xac dinh chieu dai text lon nhat va co dau cham khong
Dim RowNo As Integer
Dim ColumnNo As Integer
Dim MaxLengthText_GouKei As String
Dim MaxLengthText_GaiChuu As String
Dim MaxLengthText_JinIn As String
Dim MaxLengthText_TrungBinh As String
Dim TmpText As String
For ColumnNo = 48 To 52
For RowNo = 5 To 14
TmpText = SUS.Cells(RowNo, ColumnNo).Value
Select Case RowNo
Case 5, 11
If Len(TmpText) > Len(MaxLengthText_GouKei) Then MaxLengthText_GouKei = TmpText
Case 6, 12
If Len(TmpText) > Len(MaxLengthText_GaiChuu) Then MaxLengthText_GaiChuu = TmpText
Case 7, 13
If Len(TmpText) > Len(MaxLengthText_JinIn) Then MaxLengthText_JinIn = TmpText
Case 8, 14
If Len(TmpText) > Len(MaxLengthText_TrungBinh) Then MaxLengthText_TrungBinh = TmpText
End Select
Next
Next
'Define MaxSpaceQty
Dim MaxSpaceQty_GouKei As Integer
Dim MaxSpaceQty_GaiChuu As Integer
Dim MaxSpaceQty_JinIn As Integer
Dim MaxSpaceQty_TrungBinh As Integer
MaxSpaceQty_GouKei = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_GouKei)
MaxSpaceQty_GaiChuu = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_GaiChuu)
MaxSpaceQty_JinIn = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_JinIn)
MaxSpaceQty_TrungBinh = TBF44_ConvertTextLength2SpaceQty(MaxLengthText_TrungBinh)
'Creat BeforeTextArr
Dim BeforeTextArr(5 To 14, 48 To 52) As String
Dim TmpSpaceQty As Integer
Dim AddSpaceQty As Integer
Dim BeforeText As String
Dim TmpNote As String
For ColumnNo = 48 To 52
For RowNo = 5 To 14
TmpText = SUS.Cells(RowNo, ColumnNo).Value
TmpSpaceQty = TBF44_ConvertTextLength2SpaceQty(TmpText)
Select Case RowNo
Case 5, 11
AddSpaceQty = MaxSpaceQty_GouKei - TmpSpaceQty
If AddSpaceQty = 0 Then
BeforeText = SUS.Cells(RowNo - 1, ColumnNo).Value & TmpText
Else
BeforeText = SUS.Cells(RowNo - 1, ColumnNo).Value & TmpText & Space(AddSpaceQty)
End If
Case 6, 12
AddSpaceQty = MaxSpaceQty_GaiChuu - TmpSpaceQty
If AddSpaceQty = 0 Then
BeforeText = SUS.Cells(RowNo, 47).Value & TmpText
Else
BeforeText = SUS.Cells(RowNo, 47).Value & TmpText & Space(AddSpaceQty)
End If
Case 7, 13
AddSpaceQty = MaxSpaceQty_JinIn - TmpSpaceQty
TmpNote = SUS.Cells(RowNo, 47).Value
If AddSpaceQty = 0 Then
BeforeText = Replace(TmpNote, "xx.x", TmpText)
Else
BeforeText = Replace(TmpNote, "xx.x", TmpText) & Space(AddSpaceQty)
End If
Case 8, 14
AddSpaceQty = MaxSpaceQty_TrungBinh - TmpSpaceQty
TmpNote = SUS.Cells(RowNo, 47).Value
If AddSpaceQty = 0 Then
BeforeText = Replace(TmpNote, "xx.x", TmpText)
Else
BeforeText = Replace(TmpNote, "xx.x", TmpText) & Space(AddSpaceQty)
End If
Case 9
BeforeText = TmpText & "%"
Case 10
BeforeText = ""
End Select
BeforeTextArr(RowNo, ColumnNo) = BeforeText
Next
Next
'Creat AfterTextArr
Dim AfterTextArr(5 To 14, 48 To 52) As String
Dim SpaceNhat As String: SpaceNhat = "@"
Dim AfterText As String
For ColumnNo = 48 To 52
For RowNo = 5 To 14
BeforeText = BeforeTextArr(RowNo, ColumnNo)
Select Case RowNo
Case 5, 11
Select Case ColumnNo
Case 48, 49, 50
AfterText = BeforeText & SpaceNhat & SpaceNhat & SpaceNhat
Case 51, 52
AfterText = BeforeText & SpaceNhat
End Select
Case 6, 7, 8, 12, 13
AfterText = BeforeText & SpaceNhat
Case 9, 10, 14
AfterText = BeforeText
End Select
AfterTextArr(RowNo, ColumnNo) = AfterText
Next
Next
'Creat NoteArr(MeiRowNo,GouKeiRowNo,MokuRowNo,MeiNote,GouKeiNote,MokuNote)
Dim NoteArr(2 To 6, 0 To 5) As Variant
Dim MeiRowNo As Integer
Dim GouKeiRowNo As Integer
Dim MokuRowNo As Integer
Dim MeiNote As String
Dim GouKeiNote As String
Dim MokuNote As String
For i = 2 To 6
MeiRowNo = SUS.Cells(i, 43).Value
GouKeiRowNo = SUS.Cells(i, 44).Value
MokuRowNo = SUS.Cells(i, 45).Value
NoteArr(i, 0) = MeiRowNo
NoteArr(i, 1) = GouKeiRowNo
NoteArr(i, 2) = MokuRowNo
Next
For ColumnNo = 48 To 52
MeiNote = SUS.Cells(7, ColumnNo).Value
MeiNote = MeiNote & Tukhoa5
NoteArr(ColumnNo - 46, 3) = MeiNote
Next
For ColumnNo = 48 To 52
GouKeiNote = ""
MokuNote = ""
For RowNo = 5 To 9
AfterText = AfterTextArr(RowNo, ColumnNo)
GouKeiNote = GouKeiNote & AfterText
Next
For RowNo = 11 To 14
AfterText = AfterTextArr(RowNo, ColumnNo)
MokuNote = MokuNote & AfterText
Next
NoteArr(ColumnNo - 46, 4) = GouKeiNote
NoteArr(ColumnNo - 46, 5) = MokuNote
Next
'Write to WS sheet
For i = 2 To 6
MeiRowNo = NoteArr(i, 0)
GouKeiRowNo = NoteArr(i, 1)
MokuRowNo = NoteArr(i, 2)
MeiNote = NoteArr(i, 3)
GouKeiNote = NoteArr(i, 4)
MokuNote = NoteArr(i, 5)
If MeiRowNo > 0 Then WS.Cells(MeiRowNo, 3).Value = MeiNote
If GouKeiRowNo > 0 Then WS.Cells(GouKeiRowNo, 2).Value = GouKeiNote
If MokuRowNo > 0 Then WS.Cells(MokuRowNo, 2).Value = MokuNote
Next
End Function
Function TBF44_ConvertTextLength2SpaceQty(InputText As String) As Integer
Dim CoDauCham As Integer
Dim TextLength As Integer
Dim SpaceQty As Integer
If InStr(InputText, ".") <> 0 Then CoDauCham = 1
TextLength = Len(InputText)
SpaceQty = TextLength * 2 - CoDauCham
TBF44_ConvertTextLength2SpaceQty = SpaceQty
End Function
Function TBF45_DefineColorColumnFrom_ColorColumnTo_ColorNumber(WS As Worksheet, RowNo As Integer, ColorColumnFrom As Integer, ColorColumnTo As Integer, ColorNumber As Long)
'Setting
Dim ColorRefRow As Integer: ColorRefRow = 4
Dim ColumnFrom As Integer: ColumnFrom = 6
Dim ColumnTo As Integer: ColumnTo = 36
'Define ColorInder,Comment,ColorColumnFrom
Dim CheckColor As Variant
Dim i As Integer
For i = ColumnFrom To ColumnTo
CheckColor = TBF1810_CheckSatSunDayOffColorIndex(WS, RowNo, i)
If VarType(CheckColor) <> vbBoolean Then
ColorNumber = CheckColor
ColorColumnFrom = i
GoTo ExitFor
End If
Next
ExitFor:
'Define ColorColumnTo
For i = ColumnTo To ColumnFrom Step -1
CheckColor = TBF1810_CheckSatSunDayOffColorIndex(WS, RowNo, i)
If VarType(CheckColor) <> vbBoolean Then
ColorColumnTo = i
GoTo ExitFor2
End If
Next
ExitFor2:
End Function
Function TBF46_BackupColor(BackupColorArr() As Variant)
'Define DataSheet and SetupSheet
Dim WS As Worksheet
Set WS = ThisWorkbook.ActiveSheet
'Define RowFrom, RowTo, ColumnFrom, ColumnTo
Dim RowFrom As Integer: RowFrom = 5
Dim RowTo As Integer
Dim ColumnFrom As Integer: ColumnFrom = 6
Dim ColumnTo As Integer: ColumnTo = 36
Call TBF43_DefineRowEndNo_ByColor(WS, RowTo, 2)
'Backup Color(ColorColumnFrom, ColorColumnTo,ColorNumber
ReDim BackupColorArr(RowFrom To RowTo, 0 To 2)
Dim RowNo As Integer
Dim ColorColumnFrom As Integer
Dim ColorColumnTo As Integer
Dim ColorNumber As Long
For RowNo = RowFrom To RowTo
ColorColumnFrom = 0
ColorColumnTo = 0
ColorNumber = 0
Call TBF45_DefineColorColumnFrom_ColorColumnTo_ColorNumber(WS, RowNo, ColorColumnFrom, ColorColumnTo, ColorNumber)
BackupColorArr(RowNo, 0) = ColorColumnFrom
BackupColorArr(RowNo, 1) = ColorColumnTo
BackupColorArr(RowNo, 2) = ColorNumber
Next
End Function
Function TBF47_RestoreColor(BackupColorArr() As Variant)
'Define DataSheet and SetupSheet
Dim WS As Worksheet
Set WS = ThisWorkbook.ActiveSheet
Dim RowFrom As Integer: RowFrom = 5
Dim RowTo As Integer
Dim ColumnFrom As Integer: ColumnFrom = 6
Dim ColumnTo As Integer: ColumnTo = 36
Call TBF43_DefineRowEndNo_ByColor(WS, RowTo, 2)
Dim RefValue As String
Dim RefRow As Integer: RefRow = 4
Dim RowNo As Integer
Dim ColumnNo As Integer
Dim FillColorRange As Range
Dim ColorColumnFrom As Integer
Dim ColorColumnTo As Integer
Dim ColorNumber As Long
For RowNo = RowFrom To RowTo
ColorColumnFrom = BackupColorArr(RowNo, 0)
ColorColumnTo = BackupColorArr(RowNo, 1)
ColorNumber = BackupColorArr(RowNo, 2)
If ColorNumber <> 0 Then
For ColumnNo = ColorColumnFrom To ColorColumnTo
RefValue = WS.Cells(RefRow, ColumnNo).Value
If RefValue <> "" Then
Set FillColorRange = WS.Cells(RowNo, ColumnNo)
FillColorRange.Interior.Color = ColorNumber
End If
Next
End If
Next
End Function
Function TBF48_CreatNewSheet(NewEditMode As String)
'Get Filename from Inputbox
'InputBox(prompt[,title][,default][,xpos][,ypos][,helpfile,context])
Dim StrTitle As String
Dim StrDefautValue As String
Dim StrPrompt As String
StrPrompt = "V‹KƒV[ƒg–¼‚ð‹L“ü‚µ‚ĉº‚³‚¢B"
Dim InputBoxType As Integer: InputBoxType = 2 'chuoi ki tu
Dim StrResult As Variant
StrResult = Application.InputBox(StrPrompt, StrTitle, StrDefautValue, , , , , InputBoxType)
If VarType(StrResult) = vbBoolean Then StrResult = ""
'Creat NewSheet
Dim BeforeSheet As Worksheet
Dim OriginSheet As Worksheet
Dim AfterSheet As Worksheet
Set OriginSheet = ThisWorkbook.Sheets("Œ´–{")
Set BeforeSheet = ThisWorkbook.ActiveSheet
Select Case NewEditMode
Case "New"
OriginSheet.Copy After:=Sheets(Sheets.Count)
Case "Edit"
BeforeSheet.Copy After:=Sheets(Sheets.Count)
End Select
Set AfterSheet = Sheets(Sheets.Count)
AfterSheet.Visible = xlSheetVisible
If StrResult <> "" Then
AfterSheet.Name = StrResult
End If
AfterSheet.Select
BeforeSheet.Visible = xlSheetHidden
End Function
Function HCF4243_CreatLineOfCircleSSWith2Point(PointArr As Variant, MinPoint As Variant, MaxPoint As Variant, LineDirection As String, LineExt As Double, LayerName As String)
'Define pi
Dim Pi As Double: Pi = 4 * Atn(1)
'Creat XYArr From CenterPointArr
Dim XYPointArr As Variant
Select Case LineDirection
Case "X"
XYPointArr = HCF4108_CreatXYPointFromPointArr(PointArr, "Y")
Case "Y"
XYPointArr = HCF4108_CreatXYPointFromPointArr(PointArr, "X")
End Select
If VarType(XYPointArr) = vbBoolean Then
Exit Function
End If
'Draw OriginLine
Dim OriginLine As AcadLine
Dim OCLMinPoint As Variant
Dim OCLMaxPoint As Variant
Select Case LineDirection
Case "X"
OCLMinPoint = Thisdrawing.Utility.PolarPoint(MinPoint, Pi, LineExt)
OCLMaxPoint = Thisdrawing.Utility.PolarPoint(MaxPoint, 0, LineExt)
Case "Y"
OCLMinPoint = Thisdrawing.Utility.PolarPoint(MinPoint, -Pi / 2, LineExt)
OCLMaxPoint = Thisdrawing.Utility.PolarPoint(MaxPoint, Pi / 2, LineExt)
End Select
Set OriginLine = Thisdrawing.ModelSpace.AddLine(OCLMinPoint, OCLMaxPoint)
OriginLine.Layer = LayerName
'Creat Line of Circle
Dim EachPoint As Variant
Dim EachLine As AcadLine
For i = LBound(XYPointArr) To UBound(XYPointArr)
EachPoint = XYPointArr(i)
Select Case LineDirection
Case "X"
Call HCF4108_Call_CopyObjXorY(OriginLine, MinPoint, EachPoint, "Y")
Case "Y"
Call HCF4108_Call_CopyObjXorY(OriginLine, MinPoint, EachPoint, "X")
End Select
Next
OriginLine.Delete
End Function
Sub HCS3150_ChangeColor2ByBlock()
'(TB VBABoss) Change Color 2 ByBlock,[BB]
Thisdrawing.Utility.Prompt vbCrLf & "(TB VBABoss) Change Color 2 ByBlock" & vbLf
'Setting Public
Call HCF0000_SetPublic
'Select Object
Dim SS As AcadSelectionSet: Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
SS.SelectOnScreen
If SS.Count = 0 Then
SS.Delete
Exit Sub
End If
'Change Color 2 ByBlock
Dim EachEntity As AcadEntity
Dim EachLayerName As String
For Each EachEntity In SS
EachLayerName = EachEntity.Layer
Select Case EachLayerName
Case Pb01_NormalLayerName
EachEntity.Layer = "0"
EachEntity.Color = acByBlock
Case Else
EachEntity.Color = acByBlock
End Select
Next
SS.Delete
End Sub
Sub HCS3151_KKS_CheckZubanWithFilename()
'(TB VBABoss) KKS_CheckZubanWithFilename
'Setting Public
Call HCF0000_SetPublic
'Check ProjectName
If ProjectName <> "KKS" Then Exit Sub
'Get Part Property Block
Dim TitleBlock As AcadBlockReference
Set TitleBlock = HCF4004_GetPartPropertyBlockRef(Thisdrawing)
If TitleBlock Is Nothing Then
Exit Sub
End If
'Define Zuban From PPBlock
Dim Seiban_PP As String
Dim Zuban_PP As String
Dim Sindo_PP As String
Seiban_PP = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "製番")
Zuban_PP = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "図番")
Sindo_PP = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "進度")
'Define Zuban From Filename
Dim StrSeiban As String
Dim StrZuban As String
Dim StrSindo As String
Call HCF4241_GetSeibanZubanSindoFromFilename(StrSeiban, StrZuban, StrSindo)
'Check Zuban
Dim ErrMsg As String
If Seiban_PP <> StrSeiban Then
ErrMsg = "Seiban Wrong"
End If
If Zuban_PP <> StrZuban Then
If ErrMsg = "" Then
ErrMsg = "Zuban Wrong"
Else
ErrMsg = ErrMsg & vbNewLine & "Zuban Wrong"
End If
End If
If Sindo_PP <> StrSindo Then
If ErrMsg = "" Then
ErrMsg = "Sindo Wrong"
Else
ErrMsg = ErrMsg & vbNewLine & "Sindo Wrong"
End If
End If
'MsgBox
If ErrMsg = "" Then
Exit Sub
Else
MsgBox ErrMsg
End If
End Sub
Sub HCS3152_KSS_Balloon_2BallIsMirrorPart()
'(TB VBABoss)KSS Balloon 2 Ball Is Mirror Part,[BMI]
Thisdrawing.Utility.Prompt vbCrLf & "(TB VBABoss)KSS Balloon 2 Ball Is Mirror Part,[BMI]" & vbLf
'Settings
Dim MirrorMaker As String: MirrorMaker = "*"
Dim MirrorNote As String: MirrorNote = "(xxxxMIRROR)"
Dim MirrorColor As AcColor: MirrorColor = acBlue
Dim ZuBan_TagName As String: ZuBan_TagName = "ITEM"
Dim HinMei_TagName As String: HinMei_TagName = "JOB"
'Select 2 Balloon
Dim SS As AcadSelectionSet
Dim Ball1 As AcadBlockReference
Dim Ball2 As AcadBlockReference
Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
Thisdrawing.Utility.Prompt (vbCrLf & "Select Only 2 Balloon to Write Mirror Note:")
SS.SelectOnScreen FT, FD
If SS.Count <> 2 Then
SS.Delete
Exit Sub
Else
Set Ball1 = SS.Item(0)
Set Ball2 = SS.Item(1)
End If
'Define PartNo1, PartNo2
'Define HinMei1, HinMei2
Dim PartNo1 As String
Dim PartNo2 As String
Dim HinMei1 As String
Dim HinMei2 As String
Dim varAttributes As Variant
Dim TextString As String
varAttributes = Ball1.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
TextString = varAttributes(i).TextString
Select Case varAttributes(i).TagString
Case ZuBan_TagName
PartNo1 = Right(TextString, 4)
Case HinMei_TagName
HinMei1 = TextString
End Select
Next
varAttributes = Ball2.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
TextString = varAttributes(i).TextString
Select Case varAttributes(i).TagString
Case ZuBan_TagName
PartNo2 = Right(TextString, 4)
Case HinMei_TagName
HinMei2 = TextString
End Select
Next
'Define NewBallNo,NewHinMei
Dim NewPartNo1 As String
Dim NewPartNo2 As String
Dim NewHinMei1 As String
Dim NewHinMei2 As String
NewPartNo1 = MirrorMaker & PartNo1
NewPartNo2 = MirrorMaker & PartNo2
NewHinMei1 = HinMei1 & MirrorNote
NewHinMei2 = HinMei2 & MirrorNote
NewHinMei1 = Replace(NewHinMei1, "xxxx", PartNo2)
NewHinMei2 = Replace(NewHinMei1, "xxxx", PartNo1)
'Update PP
varAttributes = Ball1.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
Select Case varAttributes(i).TagString
Case ZuBan_TagName
varAttributes(i).TextString = NewPartNo1
Case HinMei_TagName
varAttributes(i).TextString = NewHinMei1
End Select
Next
varAttributes = Ball2.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
Select Case varAttributes(i).TagString
Case ZuBan_TagName
varAttributes(i).TextString = NewPartNo2
Case HinMei_TagName
varAttributes(i).TextString = NewHinMei2
End Select
Next
'Change Ball Color
Ball1.Color = MirrorColor
Ball2.Color = MirrorColor
SS.Delete
End Sub
Sub HCS3153_KSS_Balloon_BallIsNewPart()
'(TB VBABoss)KSS Balloon Ball Is New Part,[BNEW]
Thisdrawing.Utility.Prompt vbCrLf & "(TB VBABoss)KSS Balloon Ball Is New Part,[BNEW]" & vbLf
'Settings
Dim NewPartMaker As String: NewPartMaker = "*"
Dim NewPartColor As AcColor: NewPartColor = acMagenta
Dim ZuBan_TagName As String: ZuBan_TagName = "ITEM"
Dim HinMei_TagName As String: HinMei_TagName = "JOB"
'Select Balloon
Dim SS As AcadSelectionSet
Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
Thisdrawing.Utility.Prompt (vbCrLf & "Select Only 2 Balloon to Write Mirror Note:")
SS.SelectOnScreen FT, FD
If SS.Count = 0 Then
SS.Delete
Exit Sub
End If
'Change HinMei, PartNo
Dim EachPartNo As String
Dim EachHinMei As String
Dim varAttributes As Variant
Dim TextString As String
Dim EachBall As AcadBlockReference
For Each EachBall In SS
varAttributes = EachBall.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
TextString = varAttributes(i).TextString
Select Case varAttributes(i).TagString
Case ZuBan_TagName
EachPartNo = NewPartMaker & Right(TextString, 4)
varAttributes(i).TextString = EachPartNo
Case HinMei_TagName
EachHinMei = TextString
EachHinMei = Replace(EachHinMei, "USED", "REF")
varAttributes(i).TextString = EachHinMei
End Select
Next
EachBall.Color = NewPartColor
Next
SS.Delete
End Sub
Sub HCS3154_CreatHiddenLineOfCircle()
'(TB VBABoss)Creat Hidden Line Of Circle,[CHL]
Thisdrawing.Utility.Prompt (vbCrLf & "(TB VBABoss)Creat Hidden Line Of Circle") & vbCrLf
'Setting Layer
Call HCF0000_SetPublic
Dim CLLayer As String
Dim HiddenLayer As String
CLLayer = Pb05_CenterLayerName
HiddenLayer = Pb04_HiddenLayerName
'Othor On
Thisdrawing.SetVariable "ORTHOMODE", 1
'Define ExtDistance of Centerline
Dim CenterLineExt As Double
Call HCF4104_Call_SettingCenterLineExtendDistance(CenterLineExt)
'Select Circle
Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles")
Dim SS As AcadSelectionSet
Set SS = Thisdrawing.SelectionSets.Add("SelectOnScreen" & Now)
Dim FT(0) As Integer: Dim FD(0) As Variant
FT(0) = 0: FD(0) = "CIRCLE"
SS.SelectOnScreen FT, FD
If SS.Count = 0 Then
SS.Delete
Exit Sub
End If
'Select 2 Point
'Result (Point1,Point2,Distance,Angle,Direction,MinX,MaxX,MinY,MaxY,MinPoint,MaxPoint)
Dim Msg1 As String: Msg1 = "Select Point1"
Dim Msg2 As String: Msg2 = "Select Point2(Perpendicular)"
Dim Get2Point As Variant
Dim Direction As String
Dim MinPoint As Variant
Dim MaxPoint As Variant
Get2Point = HCF4101_Get2Point(Msg1, Msg2)
If VarType(Get2Point) = vbBoolean Then
Exit Sub
End If
Direction = Get2Point(4)
MinPoint = Get2Point(9)
MaxPoint = Get2Point(10)
'Creat CenterPointArr
Dim CenterPointArr As Variant
CenterPointArr = HCF4107_CreatCenterPointArrFromSelectSet_Circle_Arc_Block(SS)
If VarType(CenterPointArr) = vbBoolean Then
Exit Sub
End If
'Creat QuadPointArr
Dim QuadPointArr As Variant
QuadPointArr = HCF4242_CreatQuadPointArrOfCircleSS(SS, Direction, 2)
'Creat Centerline
Call HCF4243_CreatLineOfCircleSSWith2Point(CenterPointArr, MinPoint, MaxPoint, Direction, CenterLineExt, CLLayer)
'Creat HiddenLine Of Circle
Call HCF4243_CreatLineOfCircleSSWith2Point(QuadPointArr, MinPoint, MaxPoint, Direction, 0, HiddenLayer)
End Sub
Sub HCS3155_KSS_Balloon_ChangeBetweenNormalBallRefBall()
'(TB VBABoss)KSS Ball Change Between NormalBall RefBall,[BREF]
Thisdrawing.Utility.Prompt (vbCrLf & "(TB VBABoss)Creat Hidden Line Of Circle") & vbCrLf
'Setting Blockname
Dim NormalBlockname As String: NormalBlockname = "PARTBALLOON"
Dim RefBlockname As String: RefBlockname = "MATEBALLOON"
'Select Balloon
Dim SS As AcadSelectionSet
Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
Thisdrawing.Utility.Prompt (vbCrLf & "Select Balloon to Change Between Normal and Ref:")
SS.SelectOnScreen FT, FD
If SS.Count = 0 Then
SS.Delete
Exit Sub
End If
'Process
Dim EachBall As AcadBlockReference
Dim EachEffectiveName As String
Dim EachInsertBlockname As String
Dim EachXScale As Integer
Dim EachYScale As Integer
Dim EachZScale As Integer
Dim EachRotationAngle As Double
Dim EachInsertPoint As Variant
Dim EachNewBall As AcadBlockReference
Dim OldDynamicPPArr As Variant
Dim NewDynamicPPArr As Variant
Dim OldvarAttributes As Variant
Dim NewvarAttributes As Variant
Dim EachOldValue As Variant
Dim EachNewValue() As Variant
For Each EachBall In SS
'Define InsertBlockname
EachEffectiveName = EachBall.EffectiveName
Select Case EachEffectiveName
Case NormalBlockname
EachInsertBlockname = RefBlockname
Case RefBlockname
EachInsertBlockname = NormalBlockname
End Select
'Define Scale and Rotate Angle
EachXScale = EachBall.XScaleFactor
EachYScale = EachBall.YScaleFactor
EachZScale = EachBall.ZScaleFactor
EachRotationAngle = EachBall.Rotation
EachInsertPoint = EachBall.InsertionPoint
'Insert NewBall
Set EachNewBall = Thisdrawing.ModelSpace.InsertBlock(EachInsertPoint, EachInsertBlockname, EachXScale, EachYScale, EachZScale, EachRotationAngle)
'Copy Dynamic PP
If EachBall.IsDynamicBlock = True And EachNewBall.IsDynamicBlock = True Then
OldDynamicPPArr = EachBall.GetDynamicBlockProperties
NewDynamicPPArr = EachNewBall.GetDynamicBlockProperties
For i = LBound(OldDynamicPPArr) To UBound(OldDynamicPPArr)
EachOldValue = OldDynamicPPArr(i).Value
If IsArray(EachOldValue) <> True Then
NewDynamicPPArr(i).Value = EachOldValue
End If
Next
End If
'Copy AttValue
If EachBall.HasAttributes = True And EachNewBall.HasAttributes = True Then
OldvarAttributes = EachBall.GetAttributes
NewvarAttributes = EachNewBall.GetAttributes
For i = LBound(OldvarAttributes) To UBound(OldvarAttributes)
NewvarAttributes(i).TextString = OldvarAttributes(i).TextString
Next
End If
Next
'Delete
SS.Erase
SS.Delete
End Sub
Sub HCS3086_BalloonNoSearch()
'(VBA AutoCad) Balloon No Search,[BNS]
Thisdrawing.Utility.Prompt vbCrLf & "(VBA AutoCad) Balloon No Search,[BNS]" & vbLf
'Setting SearchTagString
Dim SearchTagString As String
SearchTagString = "ITEM"
'Get Balloon Number
Dim SearchBalloonNo As String
Dim GetString As Variant
GetString = HCF4049_GetString(Thisdrawing, False, vbCr & "Search Balloon No:", False)
If VarType(GetString) = vbBoolean Then
Exit Sub
Else
SearchBalloonNo = GetString
SearchBalloonNo = UCase(SearchBalloonNo)
End If
'Select All Block in Thisdrawing
Dim SS As AcadSelectionSet
Set SS = Thisdrawing.SelectionSets.Add("SS" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
SS.Select acSelectionSetAll, , , FT, FD
If SS.Count = 0 Then
SS.Delete
Exit Sub
End If
'Creat SearchResultArr
Dim SearchResultArr() As Variant
Dim EachBlockRef As AcadBlockReference
Dim varAttributes As Variant
Dim EachTagValue As String
Dim EachTextValue As String
For Each EachBlockRef In SS
If EachBlockRef.IsDynamicBlock = True And EachBlockRef.HasAttributes = True Then
varAttributes = EachBlockRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
EachTagValue = varAttributes(i).TagString
If EachTagValue = SearchTagString Then
EachTextValue = varAttributes(i).TextString
If InStr(EachTextValue, SearchBalloonNo) <> 0 Then
ReDim Preserve SearchResultArr(0 To k)
Set SearchResultArr(k) = EachBlockRef
k = k + 1
End If
End If
Next
End If
Next
SS.Delete
If k = 0 Then
MsgBox "No Balloon"
Exit Sub
End If
'Show Result
Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim Balloon As AcadBlockReference
Dim Response As VbMsgBoxResult
For i = LBound(SearchResultArr) To UBound(SearchResultArr)
Set Balloon = SearchResultArr(i)
Balloon.GetBoundingBox MinPoint, MaxPoint
Application.ZoomWindow MinPoint, MaxPoint
If k > 1 And i < UBound(SearchResultArr) Then
Response = MsgBox("Continue", vbYesNo)
Select Case Response
Case vbYes
Case vbNo
Exit Sub
End Select
End If
Next
End Sub
Function HCF4240_CreatCenterPointArrFromCircleBlockRefArr(ObjArr As Variant, RoundMode As Integer) As Variant
'Defaut Value
HCF4240_CreatCenterPointArrFromCircleBlockRefArr = False
'Check ObjArr is Array
If Func70IsEmptyArray(ObjArr) = True Then Exit Function
'Creat ObjArrCenter
Dim CenterPointArr() As Variant
Dim IsInArr As Boolean
Dim f As Integer
Dim EachBlockRef As AcadBlockReference
Dim EachCircle As AcadCircle
Dim EachEntity As AcadEntity
Dim EachCenterPoint As Variant
For i = LBound(ObjArr) To UBound(ObjArr)
Set EachEntity = ObjArr(i)
Select Case EachEntity.ObjectName
Case "AcDbBlockReference"
Set EachBlockRef = EachEntity
EachCenterPoint = EachBlockRef.InsertionPoint
Case "AcDbCircle"
Set EachCircle = EachEntity
EachCenterPoint = EachCircle.center
Case Else
GoTo GTNS1
End Select
If f = 0 Then
IsInArr = False
Else
IsInArr = HCF4173_PointAIsInPointArr(CenterPointArr, EachCenterPoint, RoundMode)
End If
If IsInArr = False Then
ReDim Preserve CenterPointArr(0 To f)
CenterPointArr(f) = EachCenterPoint
f = f + 1
End If
GTNS1:
Next
If f > 0 Then
HCF4240_CreatCenterPointArrFromCircleBlockRefArr = CenterPointArr
End If
End Function
Function HCF4241_GetSeibanZubanSindoFromFilename(StrSeiban As String, StrZuban As String, StrSindo As String)
'Define Filename
Dim StrFileName As String
StrFileName = Thisdrawing.Name
StrFileName = Before_(StrFileName, ".")
'Define Seiban,Zuban,Sindo
Dim ArrSplit As Variant
Dim Delimited As String: Delimited = "-"
ArrSplit = Split(StrFileName, Delimited)
Select Case UBound(ArrSplit)
Case 1
StrSeiban = ArrSplit(0)
StrZuban = ArrSplit(1)
StrSindo = "0"
Case 2
StrSeiban = ArrSplit(0)
StrZuban = ArrSplit(1)
StrSindo = ArrSplit(2)
If StrSindo = "00" Then StrSindo = "0"
End Select
End Function
Function HCF4242_CreatQuadPointArrOfCircleSS(CircleSS As AcadSelectionSet, XorY As String, RoundMode As Integer) As Variant
'Defaut Value
HCF4242_CreatQuadPointArrOfCircleSS = False
'Define pi
Dim Pi As Double: Pi = 4 * Atn(1)
'Check Input
If CircleSS.Count = 0 Then
Exit Function
End If
'Creat Arr
Dim QuadPointArr() As Variant
Dim EachCircle As AcadCircle
Dim EachQuadPoint1 As Variant
Dim EachQuadPoint2 As Variant
Dim EachQuadPoint3 As Variant
Dim EachQuadPoint4 As Variant
Dim EachCenterPoint As Variant
Dim EachR As Double
Dim IsInArr1 As Boolean
Dim IsInArr2 As Boolean
Dim IsInArr3 As Boolean
Dim IsInArr4 As Boolean
Dim f As Integer
For Each EachCircle In CircleSS
EachCenterPoint = EachCircle.center
EachR = EachCircle.Radius
EachQuadPoint1 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, 0, EachR)
EachQuadPoint2 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, Pi / 2, EachR)
EachQuadPoint3 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, Pi, EachR)
EachQuadPoint4 = Thisdrawing.Utility.PolarPoint(EachCenterPoint, 3 * Pi / 2, EachR)
If f = 0 Then
IsInArr1 = False
IsInArr2 = False
IsInArr3 = False
IsInArr4 = False
Else
IsInArr1 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint1, RoundMode)
IsInArr2 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint2, RoundMode)
IsInArr3 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint3, RoundMode)
IsInArr4 = HCF4173_PointAIsInPointArr(QuadPointArr, EachQuadPoint4, RoundMode)
End If
Select Case XorY
Case "Y"
If IsInArr1 = False Then
ReDim Preserve QuadPointArr(0 To f)
QuadPointArr(f) = EachQuadPoint1
f = f + 1
End If
If IsInArr3 = False Then
ReDim Preserve QuadPointArr(0 To f)
QuadPointArr(f) = EachQuadPoint3
f = f + 1
End If
Case "X"
If IsInArr2 = False Then
ReDim Preserve QuadPointArr(0 To f)
QuadPointArr(f) = EachQuadPoint2
f = f + 1
End If
If IsInArr4 = False Then
ReDim Preserve QuadPointArr(0 To f)
QuadPointArr(f) = EachQuadPoint4
f = f + 1
End If
End Select
Next
'Result
HCF4242_CreatQuadPointArrOfCircleSS = QuadPointArr
End Function
Function HCF4037X_MoveBlockToBlock(MyDrawing As AcadDocument, MoveCopy As String)
'Select Obj to Move or Copy
Dim MoveObjArr As Variant
MoveObjArr = HCF4035_SelectOnScreenByType(MyDrawing, "INSERT", "CIRCLE", "LINE", "", "")
If Func70IsEmptyArray(MoveObjArr) = True Then Exit Function
'Define MoveObjArrCenter
Dim MoveObjArrCenter As Variant
MoveObjArrCenter = HCF4036X_DefineCenterOfObjArr(MoveObjArr)
If Func70IsEmptyArray(MoveObjArrCenter) = True Then Exit Function
Dim ToObjArr As Variant
Dim ToObjArrCenter As Variant
Dim EachEntity As AcadEntity
Dim EachCopyEntiy As AcadEntity
Dim EachCenterPoint As Variant
Select Case MoveCopy
Case "Move"
'Select Move To Obj
ToObjArr = HCF4035_SelectOnScreenByType(MyDrawing, "INSERT", "CIRCLE", "", "", "")
If Func70IsEmptyArray(ToObjArr) = True Then Exit Function
'Define ToObjArrCenter
ToObjArrCenter = HCF4036X_DefineCenterOfObjArr(ToObjArr)
If Func70IsEmptyArray(ToObjArrCenter) = True Then Exit Function
'Move Obj
For i = LBound(MoveObjArr) To UBound(MoveObjArr)
Set EachEntity = MoveObjArr(i)
EachEntity.Move MoveObjArrCenter, ToObjArrCenter
Next
Case "Copy"
Do
'Select Copy To Obj
ToObjArr = HCF4035_SelectOnScreenByType(MyDrawing, "INSERT", "CIRCLE", "", "", "")
If Func70IsEmptyArray(ToObjArr) = True Then Exit Function
'Define ToObjArrCenter
ToObjArrCenter = HCF4240_CreatCenterPointArrFromCircleBlockRefArr(ToObjArr, 2)
If VarType(ToObjArrCenter) = vbBoolean Then Exit Function
'Copy Obj
For k = LBound(ToObjArrCenter) To UBound(ToObjArrCenter)
EachCenterPoint = ToObjArrCenter(k)
For i = LBound(MoveObjArr) To UBound(MoveObjArr)
Set EachEntity = MoveObjArr(i)
Set EachCopyEntiy = EachEntity.Copy
EachCopyEntiy.Move MoveObjArrCenter, EachCenterPoint
Next
Next
Loop While Func70IsEmptyArray(ToObjArrCenter) = False
End Select
End Function
;(TB VBABoss) Change Color 2 ByBlock,[BB]
(defun C:BB()
(command "-vbarun" "HCS3150_ChangeColor2ByBlock")
)
;(VBA AutoCad) Balloon No Search,[BNS]
(defun C:BNS()
(command "-vbarun" "HCS3086_BalloonNoSearch")
)
;(TB VBABoss)KSS Balloon 2 Ball Is Mirror Part,[BMI]
(defun C:BMI()
(command "-vbarun" "HCS3152_KSS_Balloon_2BallIsMirrorPart")
)
;(TB VBABoss)KSS Balloon Ball Is New Part,[BNEW]
(defun C:BNEW()
(command "-vbarun" "HCS3153_KSS_Balloon_BallIsNewPart")
)
;(TB VBABoss)Creat Hidden Line Of Circle,[CHL]
(defun C:CHL()
(command "-vbarun" "HCS3154_CreatHiddenLineOfCircle")
)
;(TB VBABoss)KSS Ball Change Between NormalBall RefBall,[BREF]
(defun C:BREF()
(command "-vbarun" "HCS3155_KSS_Balloon_ChangeBetweenNormalBallRefBall")
)