Cách chuyển font, size, màu cho text

[ageke 0]

xin chào mọi người , mình đang muốn viết 1 macro có tác dụng như sau.

Click chọn 1 đối tượng, macro sẽ tự động chuyển các thuộc tính màu (thành màu trắng), text heigh (thành 2.0000), font (thành Arial).

Đây là đoạn code của mình viết, nhưng chỉ chuyển dc màu, còn lại các đối tượng khác thì ko được, mong mọi người giúp đỡ mình

 

Sub Test()

Dim returnObj As AcadObject

Dim basePnt As Variant

On Error Resume Next

ThisDrawing.Utility.GetEntity returnObj, basePnt, "chon doi tuong"

If Err <> 0 Then

Err.Clear

MsgBox " Error"

Exit Sub

Else

returnObj.color = acWhite

Set returnObj.Font = Arial

returnObj.Update

End If

End Sub

 

Cám ơn mọi người rất nhiều.

[ageke 0]

Up.

Cả fỏum mấy trăm người hông ai giúp mình hết hả.

^^ Mong mọi người giúp với, cần gấp

Note : hậu tạ chầu cafe.

[anhcos 196]

Để đổi chiều cao của Text:

returnObj.Height = 2

 

Để đổi Font, có 2 cách:

1. tạo một Text style mới, sau đó thay đổi Textstyle của Text/MText

 

dim new_textstyle as string

new_textstyle = "xi tai moi"

 

On Error Resume Next

Thisdrawing.TextStyles.Add(new_textstyle)

 

returnObj.Stylename = new_textstyle

 

2. Đối với MText

Chỉ cần thay đổi nội dung của MText như sau:

Thêm chuỗi \f và typeface của font vào đầu nội dung của Mtext

 

VD:

returnObj.TextString ="\fArial;" & returnObj.TextString 'font Arial.ttf

returnObj.TextString ="\f.Arial;" & returnObj.TextString 'font .Arial.ttf

[ageke 0]

Cám ơn bạn rất nhiều.

Mình đã hiệu chỉnh dc phần height.

Nhưng còn phần font mình ko xử lý dc.

Cụ thể là mình đã làm như vậy.

Sub Test()

Dim returnObj As AcadObject

Dim basePnt As Variant

 

On Error Resume Next

ThisDrawing.Utility.GetEntity returnObj, basePnt, "chon doi tuong"

If Err <> 0 Then

Err.Clear

MsgBox " Error"

Exit Sub

Else

returnObj.color = acWhite

returnObj.Height = 2

returnObj.TextString = "\f Arial;" & returnObj.TextString 'font Arial.ttf

returnObj.TextString = "\f.Arial;" & returnObj.TextString 'font .Arial.ttf

returnObj.Update

End If

End Sub

 

Bạn cho mình info để liên lạc dc ko ạh

[anhcos 196]

returnObj.TextString = "\f Arial;" & returnObj.TextString 'font Arial.ttf

returnObj.TextString = "\f.Arial;" & returnObj.TextString 'font .Arial.ttf

 

Cái này chỉ dùng có 1 dòng lệnh thôi. Bỏ bớt 1 dòng.

 

Bạn dùng cách tạo style mới thì hay hơn.

[ageke 0]

Thanks bạn nhiều,

Mình đã dùng cách tạo style mới nhưng vẫn không ok.

Code của mình :

Sub Test()

Dim returnObj As AcadObject

Dim basePnt As Variant

Dim new_textstyle As String

new_textstyle = "Arial"

 

On Error Resume Next

ThisDrawing.Utility.GetEntity returnObj, basePnt, "chon doi tuong"

ThisDrawing.TextStyles.Add (new_textstyle)

 

If Err <> 0 Then

Err.Clear

MsgBox " Error"

Exit Sub

Else

returnObj.color = acWhite

returnObj.Height = 2

returnObj.StyleName = new_textstyle

returnObj.Update

End If

End Sub

[anhcos 196]

Lần trước tôi post thiếu, đã sửa và chạy thử.

 

 Sub Test()
Dim new_textstyle As String
new_textstyle_name = "new text style"

Dim new_style As AcadTextStyle
On Error Resume Next
new_style = ThisDrawing.TextStyles.Add(new_textstyle_name)
If Err <> 0 Then
Set new_style = ThisDrawing.TextStyles.Item(new_textstyle_name) 'nếu đã có thì chọn nó để xài
End If
new_style.SetFont "Arial", False, False, 0, 0

Dim returnObj As AcadObject
Dim basePnt As Variant
On Error Resume Next
ThisDrawing.Utility.GetEntity returnObj, basePnt, "chon doi tuong"

If Err <> 0 Then
Err.Clear
MsgBox " Error"
Exit Sub
Else
returnObj.color = acWhite
returnObj.Height = 2
returnObj.StyleName = new_textstyle_name
returnObj.Update
End If
End Sub

[ageke 0]

Hi, Thanks alot.

Bạn AnhCos có thể cho mình xin info để liên lạc dc không bạn.