Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
7 replies to this topic

#1 ageke

ageke

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 26 February 2010 - 12:02 PM

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.
  • 0

#2 ageke

ageke

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 March 2010 - 09:33 AM

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.
  • 0

#3 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 01 March 2010 - 12:26 PM

Để đổ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
  • 1
Clear sky!

MF Rock collection.

#4 ageke

ageke

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 March 2010 - 01:46 PM

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
  • 0

#5 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 01 March 2010 - 08:33 PM

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.
  • 0
Clear sky!

MF Rock collection.

#6 ageke

ageke

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 02 March 2010 - 08:15 AM

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
  • 0

#7 anhcos

anhcos

    biết lệnh hatchedit

  • Advance Member
  • PipPipPipPip
  • 260 Bài viết
Điểm đánh giá: 170 (tàm tạm)

Đã gửi 02 March 2010 - 09:00 AM

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

  • 0
Clear sky!

MF Rock collection.

#8 ageke

ageke

    biết pan

  • Members
  • Pip
  • 5 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 02 March 2010 - 09:44 AM

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