سلام
نمونه برنامه ای که با آن می توان در14 AUTOCAD فارسی نوشت
Dim acadApp As Object 'No need to declare acadApp here if
Dim fc As String
Dim FILE1 As String
Dim LS As String
Dim TEST As Integer
Dim PX, PY As Double
Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Private Sub setTopMost(frm As Form, ByVal Enabled As Boolean)
Dim res, FLAGS
FLAGS = SWP_NOMOVE Or SWP_NOSIZE
If Enabled = True Then
SetWindowPos frm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS
Else
SetWindowPos frm.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS
End If
End Sub
Private Sub fcad()
m = ""
h = LTrim(LS)
If IsNumeric(h) Then
For n = Len(h) To 1 Step -1
m = m + Mid(h, n, 1)
Next
Else
For T = 1 To Len(h)
f = Mid$(h, T, 1)
If f = ":" Then f = "^"
If f = "آ" Then f = "H"
If T > 1 Then p = Mid$(h, T - 1, 1)
n = Mid$(h, T + 1, 1)
If InStr(1, " ", n) <> 0 And InStr(1, "اورزژدذ", p) <> 0 Then
Select Case f 'END TEXT
Case "ا": f = "h"
Case "ب": f = "“"
Case "پ": f = "غ"
Case "ت": f = "ں"
Case "ث": f = "گ"
Case "ج": f = "ز"
Case "چ": f = "ط"
Case "ح": f = "%%177"
Case "خ": f = "®"
Case "د": f = "n"
Case "ذ": f = "b"
Case "ر": f = "v"
Case "ز": f = "c"
Case "ژ": f = "\"
Case "س": f = "؛"
Case "ش": f = "„"
Case "ص": f = "ئ"
Case "ض": f = "´"
Case "ط": f = "ة"
Case "ظ": f = "د"
Case "ع": f = "ہ"
Case "غ": f = "ج"
Case "ف": f = "½"
Case "ق": f = "·"
Case "ک": f = "ق"
Case "گ": f = "ل"
Case "ل": f = "–"
Case "م": f = "¥"
Case "ن": f = "¢"
Case "و": f = ","
Case "ه": f = "œ"
Case "ی": f = "چ"
End Select
Else
If InStr(1, "آدذ رزوژا:", p) <> 0 And n <> " " Then
Select Case f 'first text
Case "ا": f = "h"
Case "ب": f = "f"
Case "پ": f = "`"
Case "ت": f = "j"
Case "ث": f = "e"
Case "ج": f = "["
Case "چ": f = "]"
Case "ح": f = "p"
Case "خ": f = "o"
Case "د": f = "n"
Case "ذ": f = "b"
Case "ر": f = "v"
Case "ز": f = "c"
Case "ژ": f = "\"
Case "س": f = "s"
Case "ش": f = "a"
Case "ص": f = "w"
Case "ض": f = "q"
Case "ط": f = "x"
Case "ظ": f = "z"
Case "ع": f = "u"
Case "غ": f = "y"
Case "ف": f = "t"
Case "ق": f = "r"
Case "ک": f = ";"
Case "گ": f = "'"
Case "ل": f = "g"
Case "م": f = "l"
Case "ن": f = "k"
Case "و": f = ","
Case "ه": f = "i"
Case "ی": f = "d"
Case "ئ": f = "m"
End Select
End If
If InStr(1, " ", n) <> 0 And InStr(1, "باپتثجچحخسشصضطظعغفقکگلئم رزژنهی", p) <> 0 Then
Select Case f ' end text
Case "ا": f = "—"
Case "ب": f = "“"
Case "پ": f = "غ"
Case "ت": f = ""
Case "ث": f = "گ"
Case "ج": f = "ز"
Case "چ": f = "ط"
Case "ح": f = "%%177"
Case "خ": f = "®"
Case "د": f = "©"
Case "ذ": f = "…"
Case "ر": f = "ء"
Case "ز": f = "ˆ"
Case "ژ": f = "س"
Case "س": f = "؛"
Case "ش": f = "„"
Case "ص": f = "إ"
Case "ض": f = "³"
Case "ط": f = "ة"
Case "ظ": f = "د"
Case "ع": f = "؟"
Case "غ": f = "ث"
Case "ف": f = "½"
Case "ق": f = "·"
Case "ک": f = "ف"
Case "گ": f = "ل"
Case "ل": f = "•"
Case "م": f = "¤"
Case "ن": f = "،"
Case "و": f = "â"
Case "ه": f = "›"
Case "ی": f = "Œ"
End Select
Else
Select Case f 'center text
Case "ا": f = "—"
Case "ب": f = "‘"
Case "پ": f = "ظ"
Case "ت": f = ""
Case "ث": f = "ژ"
Case "ج": f = "ذ"
Case "چ": f = "ض"
Case "ح": f = "¯"
Case "خ": f = "¬"
Case "د": f = "©"
Case "ذ": f = "…"
Case "ر": f = "ء"
Case "ز": f = "ˆ"
Case "ژ": f = "س"
Case "س": f = "¸"
Case "ش": f = "‚"
Case "ص": f = "ؤ"
Case "ض": f = "²"
Case "ط": f = "ا"
Case "ظ": f = "ح"
Case "ع": f = "¾"
Case "غ": f = "ت"
Case "ف": f = "»"
Case "ق": f = "µ"
Case "ک": f = "ـ"
Case "گ": f = "ک"
Case "ل": f = "”"
Case "م": f = "£"
Case "ن": f = " "
Case "و": f = "â"
Case "ه": f = "ڑ"
Case "ی": f = "‹"
End Select
End If
End If
m = m + f
Next
End If
fc = m
End Sub
Private Sub Combo1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Call INSERT
If KeyAscii = 16 Then TEST = 0 'CTRL + P
End Sub
Private Sub INSERT()
LS = Combo1.Text
TT = 1
For T = 0 To Combo1.ListCount - 1
Combo1.ListIndex = T
If LS = Combo1.Text Then TT = 0
Next
If TT = 1 Then Combo1.AddItem (LS)
Form1.WindowState = 1
Call fcad
Dim activeDc As Object
Set activeDc = acadApp.ActiveDocument
Dim pnt As Variant
If TEST > 0 Then
PY = PY - (Val(Text2.Text) * 2)
Else
pnt = activeDc.UTILITY.GetPoint(, "Enter Point : ")
PX = pnt(0)
PY = pnt(1)
End If
Dim startPoint(0 To 2) As Double
startPoint(0) = PX
startPoint(1) = PY
startPoint(2) = 0#
Set activeDc = acadApp.ActiveDocument.PaperSpace.AddText(LTri m(fc), startPoint, Val(Text2.Text))
Set activeDc = acadApp.ActiveDocument.ModelSpace.AddText(LTri m(fc), startPoint, Val(Text2.Text))
Combo1.Text = ""
Form1.WindowState = 0
TEST = TEST + 1
End Sub
Private Sub Form_Load()
setTopMost Me, True
TEST = 0
FILE1 = App.Path
FILE1 = FILE1 + "\LIST.TXT"
If Dir(FILE1) <> "" Then
Open FILE1 For Input As #1
While Not EOF(1)
Input #1, A
Combo1.AddItem (A)
Wend
Close (1)
End If
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox Err.Description
Exit Sub
End If
End If
acadApp.Visible = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Open FILE1 For Output As #1
For T = 0 To Combo1.ListCount - 1
Combo1.ListIndex = T
Print #1, Combo1.Text
Next
End Sub
قوانین ایجاد تاپیک در تالار
پاسخ با نقل قول