VBA
Discuss AutoCAD ActiveX and VBA (Visual Basic for Applications) questions here.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Changing Laptop my UserForm doesnt work?

17 REPLIES 17
Reply
Message 1 of 18
berat_sinani
824 Views, 17 Replies

Changing Laptop my UserForm doesnt work?

Through UserFroms in Autocad I designed the code to draw the polygons, on my laptop it works very well, as soon as I put the same application somewhere else everything works but the drawing becomes only squares or triangles but not the drawing that should be presented.

17 REPLIES 17
Message 2 of 18
norman.yuan
in reply to: berat_sinani

No one would be able to suggest anything useful without seeing your code, except be pretty sure that your code is wrong.

 

Norman Yuan

Drive CAD With Code

EESignature

Message 3 of 18
berat_sinani
in reply to: norman.yuan

Dear, thank your for your reply, here is my UserForms, when I click button ..., OpenDialog will be show, and open CSV File, after they will be in list as below X, Y and Z:

UserForm.png

After Executing, I will have this results as below:

Screenshot_2.png

As you can see, completely my Parcel is drawed perfectly, but this application with noone changes, look how this draws:
Screen3.jpg

Everything is differently, 

 

Please below you can see all the sourcecode. Please code is in Event: cmdOpenFile_Click()

Dim Prova As Integer
Dim Points(0 To 100) As Double
Const acLayoutSpace As Integer = 1
Const acModelSpace As Integer = 0

Private Sub cmdEmërtoni_Parcelën_Click()
Dim Nr_i_Parcelës As String
Dim X, Y As Double

Nr = InputBox("Ju lutemi shkruani Numrin e Parcelës", "Numri i Parcelës", "Shkruani Numrin e Parcelës")
X = MesatarjaListbox(lstKord_X)
Y = MesatarjaListbox(lstKord_Y)

Dim mtextObj As AcadMText
Dim insertPoint(0 To 2) As Double
Dim width As Double
Dim textString As String

width = 25

insertPoint(0) = CDbl(X) - 5
insertPoint(1) = CDbl(Y) - 2.5
insertPoint(2) = CDbl(500)
textString = Nr

Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)
End Sub

Private Sub cmdOpenFile_Click()
On Error Resume Next
Dim Filter As String
Dim InitialDir As String
Dim DialogTitle As String
Dim OutputStr As String
Dim Pikat As Integer
Pikat = 1
Filter = "Comma Separated Values (*.csv)" + Chr$(0) + "*.csv" + Chr$(0) + _
"All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
DialogTitle = "Hapja e Dosjes!"
OutputStr = ShowOpen(Filter, "", DialogTitle)
If Len(OutputStr) = 0 Then
txtFilename.Text = "Nuk keni zgjedhur Dosje!"
Else
txtFilename.Text = OutputStr
txtNr_i_Pikave.Text = GetRecordCount(OutputStr) - 1
Dim fileContent As String
Open OutputStr For Input As #1
Do Until EOF(1)
Line Input #1, fileContent
' Vendosni rreshtin e lexuar në TextBox
ListBox1.AddItem fileContent
' Këtu mbushet listat
Dim TextStrng As String
Dim Result() As String
Dim DisplayText As String
TextStrng = fileContent
Result = Split(TextStrng, ",")
For i = LBound(Result()) To UBound(Result())
If i = 0 Then
lstKord_Pika.AddItem Result(i)
LblPika1.Caption = Result(i)
ElseIf i = 1 Then
lstKord_X.AddItem Result(i)
LblPika2.Caption = Result(i)
lstKordinatat.AddItem Result(i)
ElseIf i = 2 Then
lstKord_Y.AddItem Result(i)
LblPika3.Caption = Result(i)
lstKordinatat.AddItem Result(i)
ElseIf i = 3 Then
lstKord_Z.AddItem Result(i)
LblPika4.Caption = Result(i)

' Leximi i rreshtit të parë
lblFillestare_Pika1.Caption = GetFirstItem(lstKord_Pika)
lblFillestare_Pika2.Caption = GetFirstItem(lstKord_X)
lblFillestare_Pika3.Caption = GetFirstItem(lstKord_Y)
lblFillestare_Pika4.Caption = GetFirstItem(lstKord_Z)

lblParaprake_Pika1.Caption = GetPreviousItem(Pikat, lstKord_Pika)
lblParaprake_Pika2.Caption = GetPreviousItem(Pikat, lstKord_X)
lblParaprake_Pika3.Caption = GetPreviousItem(Pikat, lstKord_Y)
lblParaprake_Pika4.Caption = GetPreviousItem(Pikat, lstKord_Z)

Pikat = Pikat + 1
If chckVetëmImporto.Value = False Then
' Vizatimi i Pikave
If chckVizato_Pikat.Value = True Then
Dim pointObj As AcadPoint
Dim location(0 To 2) As Double
location(0) = LblPika2.Caption: location(1) = LblPika3.Caption: location(2) = LblPika4.Caption
Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)
End If

' Vizatimi i rrethit
If chckVizato_Rrathët.Value = True Then
Dim centerPoint(0 To 2) As Double
Dim radius As Double
Dim circleObj As AcadCircle

centerPoint(0) = CDbl(LblPika2.Caption)
centerPoint(1) = CDbl(LblPika3.Caption)
centerPoint(2) = CDbl(LblPika4.Caption)
radius = 0.2
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)

If Not circleObj Is Nothing Then
circleObj.color = acRed
Else
MsgBox "Ndodhi një problem gjatë krijimit të objektit cirkular.", vbExclamation
End If
End If


' Vizatimi i Tekstit
If chckVizato_Përshkrimin.Value = True Then
Dim mtextObj As AcadMText
Dim insertPoint(0 To 2) As Double
Dim width As Double
Dim textString As String


mtextObj.TextHeight = 20#
mtextObj.TextWidth = 20#

insertPoint(0) = CDbl(LblPika2.Caption) + 2.5
insertPoint(1) = CDbl(LblPika3.Caption) - 2.5
insertPoint(2) = CDbl(LblPika4.Caption)
textString = LblPika1.Caption

Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)
End If
End If
End If
Next i
Loop
End If
Close #1
lstKordinatat.AddItem (lblFillestare_Pika2.Caption)
lstKordinatat.AddItem (lblFillestare_Pika3.Caption)
If chckVetëmImporto.Value = False Then
If chckVizato_Parcelën.Value = True Then
VizatoPolyline
End If
End If
cmdEmërtoni_Parcelën_Click
ThisDrawing.SendCommand "_ZOOM E" & vbCr
End Sub

Private Sub Open_File(ByVal FileName As String)
On Error Resume Next
Dim Pikat As Integer
Pikat = 1

Dim OutputStr As String

OutputStr = FileName

If Len(OutputStr) = 0 Then
txtFilename.Text = "Nuk keni zgjedhur Dosje!"
Else
txtFilename.Text = OutputStr
txtNr_i_Pikave.Text = GetRecordCount(OutputStr) - 1
Dim fileContent As String
Open OutputStr For Input As #1
Do Until EOF(1)
Line Input #1, fileContent
' Vendosni rreshtin e lexuar në TextBox
ListBox1.AddItem fileContent
' Këtu mbushet listat
Dim TextStrng As String
Dim Result() As String
Dim DisplayText As String
TextStrng = fileContent
Result = Split(TextStrng, ",")
For i = LBound(Result()) To UBound(Result())
If i = 0 Then
lstKord_Pika.AddItem Result(i)
LblPika1.Caption = Result(i)
ElseIf i = 1 Then
lstKord_X.AddItem Result(i)
LblPika2.Caption = Result(i)
lstKordinatat.AddItem Result(i)
ElseIf i = 2 Then
lstKord_Y.AddItem Result(i)
LblPika3.Caption = Result(i)
lstKordinatat.AddItem Result(i)
ElseIf i = 3 Then
lstKord_Z.AddItem Result(i)
LblPika4.Caption = Result(i)

' Leximi i rreshtit të parë
lblFillestare_Pika1.Caption = GetFirstItem(lstKord_Pika)
lblFillestare_Pika2.Caption = GetFirstItem(lstKord_X)
lblFillestare_Pika3.Caption = GetFirstItem(lstKord_Y)
lblFillestare_Pika4.Caption = GetFirstItem(lstKord_Z)

lblParaprake_Pika1.Caption = GetPreviousItem(Pikat, lstKord_Pika)
lblParaprake_Pika2.Caption = GetPreviousItem(Pikat, lstKord_X)
lblParaprake_Pika3.Caption = GetPreviousItem(Pikat, lstKord_Y)
lblParaprake_Pika4.Caption = GetPreviousItem(Pikat, lstKord_Z)

Pikat = Pikat + 1
If chckVetëmImporto.Value = False Then
' Vizatimi i Pikave
If chckVizato_Pikat.Value = True Then
Dim pointObj As AcadPoint
Dim location(0 To 2) As Double
location(0) = LblPika2.Caption: location(1) = LblPika3.Caption: location(2) = LblPika4.Caption
Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)
End If

' Vizatimi i rrethit
If chckVizato_Rrathët.Value = True Then
Dim centerPoint(0 To 2) As Double
Dim radius As Double
Dim circleObj As AcadCircle

centerPoint(0) = CDbl(LblPika2.Caption)
centerPoint(1) = CDbl(LblPika3.Caption)
centerPoint(2) = CDbl(LblPika4.Caption)
radius = 0.2
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)

If Not circleObj Is Nothing Then
circleObj.color = acRed
Else
MsgBox "Ndodhi një problem gjatë krijimit të objektit cirkular.", vbExclamation
End If
End If


' Vizatimi i Tekstit
If chckVizato_Përshkrimin.Value = True Then
Dim mtextObj As AcadMText
Dim insertPoint(0 To 2) As Double
Dim width As Double
Dim textString As String


mtextObj.TextHeight = 20#
mtextObj.TextWidth = 20#

insertPoint(0) = CDbl(LblPika2.Caption) + 2.5
insertPoint(1) = CDbl(LblPika3.Caption) - 2.5
insertPoint(2) = CDbl(LblPika4.Caption)
textString = LblPika1.Caption

Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)
End If
End If
End If
Next i
Loop
End If
Close #1
lstKordinatat.AddItem (lblFillestare_Pika2.Caption)
lstKordinatat.AddItem (lblFillestare_Pika3.Caption)
If chckVetëmImporto.Value = False Then
If chckVizato_Parcelën.Value = True Then
VizatoPolyline
End If
End If
cmdEmërtoni_Parcelën_Click
ThisDrawing.SendCommand "_ZOOM E" & vbCr
End Sub

Function GetRecordCount(filePath As String) As Long
Dim recordCount As Long
Dim fileContent As String

With CreateObject("Scripting.FileSystemObject")
If .FileExists(filePath) Then
With .OpenTextFile(filePath, 1, False)
fileContent = .ReadAll
.Close
End With
recordCount = UBound(Split(fileContent, vbCrLf)) + 1
Else
MsgBox "File not found: " & filePath, vbExclamation
End If
End With
GetRecordCount = recordCount
End Function

Function GetFirstItem(lstBox As MSForms.listbox) As String
If lstBox.ListCount > 0 Then
GetFirstItem = lstBox.List(0)
Else
GetFirstItem = ""
End If
End Function

Function GetPreviousItem(ByVal Indeksi As Integer, ByVal lstBox As MSForms.listbox) As String
If Indeksi >= 1 And Indeksi <= lstBox.ListCount Then
' Merr vleren nga ListBox dhe shfaq ose përdor ndryshe sipas nevojave
GetPreviousItem = lstBox.List(Indeksi - 1)
Else
' Nese indeksi eshte jashte kufijve, shfaq nje mesazh
GetPreviousItem = "Indeksi i pavlefshëm!"
End If
End Function

Function CreatePoint(X As Double, Y As Double, Z As Double) As Variant
Dim point(0 To 2) As Double
point(0) = X
point(1) = Y
point(2) = Z
CreatePoint = point
End Function

Private Sub cmdParcelëeRe_ImportoCSV_Click()
On Error Resume Next
Dim Filter As String
Dim InitialDir As String
Dim DialogTitle As String
Dim OutputStr As String
Dim Pikat As Integer
Pikat = 1
Filter = "Comma Separated Values (*.csv)" + Chr$(0) + "*.csv" + Chr$(0) + _
"All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
DialogTitle = "Hapja e Dosjes!"
OutputStr = ShowOpen(Filter, "", DialogTitle)
If Len(OutputStr) = 0 Then
lblParcelëeRe_Info.Caption = "Nuk keni Dosje!"
Else
lblParcelëeRe_Info.Caption = OutputStr
Dim fileContent As String
Open OutputStr For Input As #1
Do Until EOF(1)
Line Input #1, fileContent
' Këtu mbushet listat
Dim TextStrng As String
Dim Result() As String
Dim DisplayText As String
TextStrng = fileContent
Result = Split(TextStrng, ",")
For i = LBound(Result()) To UBound(Result())
If i = 0 Then
lstParcelëeRe_Pika.AddItem Result(i)
ElseIf i = 1 Then
lstParcelëeRe_X.AddItem Result(i)
ElseIf i = 2 Then
lstParcelëeRe_Y.AddItem Result(i)
ElseIf i = 3 Then
lstParcelëeRe_Z.AddItem Result(i)
End If
Next i
Loop
End If
Close #1
End Sub

Private Sub cmdParcelëeRe_KrijoNdarje_Click()
' Krijimi i Pikave në dy Skajet e Vijës
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Dim pointObj As AcadPoint
Dim location(0 To 2) As Double
location(0) = Val(CDbl(txtParcelëeRe_X1.Text)): location(1) = Val(CDbl(txtParcelëeRe_Y1.Text)): location(2) = Val(CDbl(txtParcelëeRe_Z1.Text))
Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)

location(0) = Val(CDbl(txtParcelëeRe_X2.Text)): location(1) = Val(CDbl(txtParcelëeRe_Y2.Text)): location(2) = Val(CDbl(txtParcelëeRe_Z2.Text))
Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)

' Vizatimi i rrathëve për të dy pikat
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Dim circleObj As AcadCircle
Dim centerPoint(0 To 2) As Double
Dim radius As Double

centerPoint(0) = Val(CDbl(txtParcelëeRe_X1.Text)): centerPoint(1) = Val(CDbl(txtParcelëeRe_Y1.Text)): centerPoint(2) = Val(CDbl(txtParcelëeRe_Z1.Text))
radius = 0.2
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)

If Not circleObj Is Nothing Then
circleObj.color = acRed
Else
MsgBox "Ndodhi një problem gjatë krijimit të objektit cirkular.", vbExclamation
End If

centerPoint(0) = Val(CDbl(txtParcelëeRe_X2.Text)): centerPoint(1) = Val(CDbl(txtParcelëeRe_Y2.Text)): centerPoint(2) = Val(CDbl(txtParcelëeRe_Z2.Text))
radius = 0.2
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)

If Not circleObj Is Nothing Then
circleObj.color = acRed
Else
MsgBox "Ndodhi një problem gjatë krijimit të objektit cirkular.", vbExclamation
End If

'Vizatimi i tekstit
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

Dim mtextObj As AcadMText
Dim insertPoint(0 To 2) As Double
Dim width As Double
Dim textString As String

insertPoint(0) = CDbl(txtParcelëeRe_X1.Text) + 2.5: insertPoint(1) = CDbl(txtParcelëeRe_Y1.Text) - 2.5: insertPoint(2) = CDbl(txtParcelëeRe_Z1.Text)
textString = txtParcelëeRe_Pika1.Text
Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)

insertPoint(0) = CDbl(txtParcelëeRe_X2.Text) + 2.5: insertPoint(1) = CDbl(txtParcelëeRe_Y2.Text) - 2.5: insertPoint(2) = CDbl(txtParcelëeRe_Z2.Text)
textString = txtParcelëeRe_Pika2.Text
Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)

ThisDrawing.SendCommand "_ZOOM E" & vbCr
ThisDrawing.Regen acActiveViewport
End Sub

Private Sub cmdParcelëeRe_Pastro_Click()
lstParcelëeRe_Pika.Clear
lstParcelëeRe_X.Clear
lstParcelëeRe_Y.Clear
lstParcelëeRe_Z.Clear
End Sub

Private Sub cmdParcelëeRe_PastroPikat_Click()
txtParcelëeRe_Pika1.Text = ""
txtParcelëeRe_X1.Text = ""
txtParcelëeRe_Y1.Text = ""
txtParcelëeRe_Z1.Text = ""
txtParcelëeRe_Pika2.Text = ""
txtParcelëeRe_X2.Text = ""
txtParcelëeRe_Y2.Text = ""
txtParcelëeRe_Z2.Text = ""
End Sub

Private Sub cmdParcelëeRe_ShtoManualisht_Click()
Dim Përgjigjja As String
Përgjigjja = InputBox("Ju lutemi jepni emrine pikës pët t'u futur në Tabelë!", "Emri i Pikës", "Shkruani këtu!")
lstParcelëeRe_Pika.AddItem Përgjigjja

Përgjigjja = InputBox("Ju lutemi jepni kordinatën X të pikës pët t'u futur në Tabelë!", "Kordinata X", "Shkruani këtu!")
lstParcelëeRe_X.AddItem Përgjigjja

Përgjigjja = InputBox("Ju lutemi jepni kordinatën Y të pikës pët t'u futur në Tabelë!", "Kordinata Y", "Shkruani këtu!")
lstParcelëeRe_Y.AddItem Përgjigjja

Përgjigjja = InputBox("Ju lutemi jepni kordinatën Z të pikës pët t'u futur në Tabelë!", "Kordinata Z", "Shkruani këtu!")
lstParcelëeRe_Z.AddItem Përgjigjja
End Sub



Private Sub cmdPaste_Data_Click()
' Split the text on spaces and insert each word on a new line with row numbers
Dim inputText As String
Dim words() As String
Dim i As Integer
Dim rowNumber As Integer

' Get the text from the multiline textbox
inputText = Me.txtMultilineText.Value

' Split the text into an array of words
words = Split(inputText, " ")

' Clear the existing text in the textbox
Me.txtMultilineText.Value = ""

' Initialize row number
rowNumber = 1

' Insert each word on a new line with row numbers
For i = LBound(words) To UBound(words)
Me.txtMultilineText.Value = Me.txtMultilineText.Value & rowNumber & "," & words(i) & ",500" & vbCrLf
rowNumber = rowNumber + 1
Next i

Fshier_Rreshtin_e_Fundit


' Save the content of the MultiLineTextBox as a CSV file on the desktop
Dim filePath As String
Dim fileNumber As Integer

' Get the desktop path
filePath = Environ("USERPROFILE") & "\Desktop\Parcela.csv"

' Open a new file for writing
fileNumber = FreeFile
Open filePath For Output As fileNumber

' Write the content of the MultiLineTextBox to the file
Print #fileNumber, Replace(Me.txtMultilineText.Value, vbCrLf, vbNewLine)

' Close the file
Close fileNumber

Open_File filePath

MsgBox "Dizajni është krijuar!" & vbNewLine & "Mbylleni aplikacionin!", vbInformation
End Sub

Private Sub Fshier_Rreshtin_e_Fundit()
Dim linesArray() As String
Dim newContent As String
Dim i As Integer

' Split the lines of the textbox content into an array
linesArray = Split(txtMultilineText.Value, vbCrLf)

' Check if there are at least two lines to delete
If UBound(linesArray) >= 1 Then
' Rebuild the content without the last two lines
For i = 0 To UBound(linesArray) - 2
newContent = newContent & linesArray(i) & vbCrLf
Next i

' Update the textbox content
txtMultilineText.Value = newContent
End If
End Sub

Private Sub lstKord_Pika_Click()
Dim Nr As Integer
Dim X As String
Dim Y As String
Dim Z As String
Dim PikaPërNdarje As String

Nr = lstKord_Pika.ListIndex

X = CStr(lstKord_X.List(Nr))
Y = CStr(lstKord_Y.List(Nr))
Z = CStr(lstKord_Z.List(Nr))
PikaPërNdarje = CStr(lstKord_Pika.List(Nr))

txtAktuale_X.Text = X
txtAktuale_Y.Text = Y
txtAktuale_Z.Text = Z
txtNdarje_Pika_e_Re.Text = PikaPërNdarje
End Sub

Private Sub lstKord_Pika_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If Len(txtNdarje_X1.Text) = 0 Then
txtNdarje_X1.Text = txtAktuale_X.Text
txtNdarje_Y1.Text = txtAktuale_Y.Text
Else
txtNdarje_X2.Text = txtAktuale_X.Text
txtNdarje_Y2.Text = txtAktuale_Y.Text
txtNdarje_Z.Text = txtAktuale_Z.Text

End If
End Sub

Private Sub lstParcelëeRe_Pika_Click()
Dim Nr As Integer
Nr = lstParcelëeRe_Pika.ListIndex

lstParcelëeRe_X.ListIndex = Nr
lstParcelëeRe_Y.ListIndex = Nr
lstParcelëeRe_Z.ListIndex = Nr

End Sub

Private Sub lstParcelëeRe_Pika_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim Nr As Integer
Nr = lstParcelëeRe_Pika.ListIndex

If Len(txtParcelëeRe_Pika1.Text) = 0 Then
txtParcelëeRe_Pika1.Text = lstParcelëeRe_Pika.List(Nr)
txtParcelëeRe_X1.Text = lstParcelëeRe_X.List(Nr)
txtParcelëeRe_Y1.Text = lstParcelëeRe_Y.List(Nr)
txtParcelëeRe_Z1.Text = lstParcelëeRe_Z.List(Nr)
Else
txtParcelëeRe_Pika2.Text = lstParcelëeRe_Pika.List(Nr)
txtParcelëeRe_X2.Text = lstParcelëeRe_X.List(Nr)
txtParcelëeRe_Y2.Text = lstParcelëeRe_Y.List(Nr)
txtParcelëeRe_Z2.Text = lstParcelëeRe_Z.List(Nr)
End If
End Sub

Private Sub UserForm_Activate()
Me.top = 50
Me.Left = 800
End Sub


Sub VizatoPolyline()
Dim plineObj As AcadLWPolyline
Dim ArraySize As Integer
ArraySize = lstKordinatat.ListCount - 1
Dim e As Integer

' Deklaroni vargun duke përdorur ReDim për ta përshtatur madhësinë
Dim Points() As Double
ReDim Points(0 To ArraySize)

For e = 0 To ArraySize
Points(e) = lstKordinatat.List(e)
Next e

' Create a lightweight Polyline object in model space
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points)
plineObj.Closed = True
plineObj.ZoomExtents
End Sub


Sub VizatoNdarjen()
' Vizatimi i Pikave
Dim pointObj As AcadPoint
Dim location(0 To 2) As Double
location(0) = txtNdarje_X1.Text: location(1) = txtNdarje_X1.Text: location(2) = txtNdarje_Z.Text
Set pointObj = ThisDrawing.ModelSpace.AddPoint(location)

' Vizatimi i rrethit
Dim centerPoint(0 To 2) As Double
Dim radius As Double
Dim circleObj As AcadCircle

centerPoint(0) = CDbl(txtNdarje_X1.Text)
centerPoint(1) = CDbl(txtNdarje_Y1.Text)
centerPoint(2) = CDbl(txtNdarje_Z.Text)
radius = 0.2
Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPoint, radius)

If Not circleObj Is Nothing Then
circleObj.color = acRed
Else
MsgBox "Ndodhi një problem gjatë krijimit të objektit cirkular.", vbExclamation
End If

' Vizatimi i Tekstit
Dim mtextObj As AcadMText
Dim insertPoint(0 To 2) As Double
Dim width As Double
Dim textString As String

insertPoint(0) = CDbl(txtNdarje_X1.Text) + 2.5
insertPoint(1) = CDbl(txtNdarje_X2.Text) - 2.5
insertPoint(2) = CDbl(txtNdarje_Z.Text)
textString = txtNdarje_Pika_e_Re.Text

Set mtextObj = ThisDrawing.ModelSpace.AddMText(insertPoint, width, textString)

' Vizatimi i ndarjes
Dim plineObj As AcadLWPolyline
Dim ArraySize As Integer
ArraySize = lstKordinatat.ListCount - 1
Dim e As Integer

' Declare the array using ReDim to match the size
Dim Points() As Double
ReDim Points(0 To 3)

Points(0) = CDbl(txtNdarje_X1.Text)
Points(1) = CDbl(txtNdarje_Y1.Text)
Points(2) = CDbl(txtNdarje_X2.Text)
Points(3) = CDbl(txtNdarje_Y2.Text)

' Create a lightweight Polyline object in model space
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points)

' Set the color of the polyline to red
plineObj.color = acRed
plineObj.Closed = True
End Sub

Function MesatarjaListbox(listbox As MSForms.listbox) As Double
Dim total As Double
Dim count As Integer
If listbox.ListCount > 0 Then
For i = 0 To listbox.ListCount - 1
total = total + CDbl(listbox.List(i))
count = count + 1
Next i
If count > 0 Then
MesatarjaListbox = total / count
Else
MsgBox "Listbox është bosh."
End If
Else
MsgBox "Listbox është bosh."
End If
End Function


Anyway thanks a lot for your support!

 

*Moderator edit* Please post your code in a code window.

Message 4 of 18
berat_sinani
in reply to: norman.yuan

Hey, My Friends
Thank you, for your reply to AutoDESK, please see my source code in the post.


Berat
Message 5 of 18
Ed.Jobe
in reply to: berat_sinani

The code by itself is not really helpful because we can't test it. Please provide a complete solution. You can't post a dvb to the forum, but you can post a zip or dwg. Try embedding the project in a dwg and then post is with a sample csv.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 6 of 18
berat_sinani
in reply to: Ed.Jobe

Dear
Please find attached

Message 7 of 18
Ed.Jobe
in reply to: berat_sinani

Sorry, there is no attachment. You may need to zip the file.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 8 of 18
berat_sinani
in reply to: Ed.Jobe

Dear,

Now, I have attached a archived rar program.

Message 9 of 18
Ed.Jobe
in reply to: berat_sinani

Unfortunately, I don't have access to a program that can decompress a rar file. Can you use Windows>Send To>Compressed (zip) Folder to compress the files. Remember to include a sample csv of your data.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 10 of 18
norman.yuan
in reply to: berat_sinani

@Ed.Jobe , if you use Win11, it can extract *rar file: simply right-click the RAR file and select "Extract All...".

Norman Yuan

Drive CAD With Code

EESignature

Message 11 of 18
Ed.Jobe
in reply to: norman.yuan

Thanks @norman.yuan , but I'm still on win10.

Testing to see if you can attach a dwg with an embedded project.

***It works. @berat_sinani You can just embed your project in a sample dwg using the VBAMAN command.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 12 of 18
berat_sinani
in reply to: Ed.Jobe

Dear,
Please find attached ZIP File also is csv file included, thanks a lot, there is no error or bug, but the final in my origin laptop where i have programming this draws me this and everything works perfect as below:
1.png

But, when same application I am copying to another pc where also is AutoCad 2006 and i am executing this, i have this drawing as below: 

2.jpg

 

So, the code does not give me any error, but the drawing is not what it should be, but only straight lines and not the plot that should be according to the coordinates.

Message 13 of 18
Ed.Jobe
in reply to: berat_sinani

2006 has a problem? What's the version of AutoCAD where the code runs correctly?

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 14 of 18
berat_sinani
in reply to: Ed.Jobe

Dear,

If I try it in AutoCad 2006 on my laptop it works perfectly as you can see, only when I change it to another computer it doesn't make the drawing, that is the same version of autocad.

 

I have tried it on several computers and this exact problem occurs on every computer

Message 15 of 18
Ed.Jobe
in reply to: berat_sinani

Is your version of AutoCAD 2006 a 32 bit version or 64 bit version?

I'm unable to figure out the program flow because there are so many steps and I can't read your language.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 16 of 18
berat_sinani
in reply to: Ed.Jobe

Dear,

 

Please find this video 

 

So, please also find all files Modules, Forms, CSV files to see what you can do!?

Message 17 of 18
Ed.Jobe
in reply to: berat_sinani

I had to modify the csv import to get it to work for me, but it drew the parcel correctly. I would have to spend more time looking over the code to debug it. But it has to be some variable that doesn't exist on the other pc's. It would help if you provided some of their specifications, e.g. AutoCAD version, Windows version, pc specs, and anything else that might be different from your pc. You can run the lisp below to export all the AutoCAD system variables. Run it on your pc and theirs and upload both files. It is actually a command macro you can add to your cui.

^C^C(if (null vars2scr)(load "acadinfo"));vars2scr  

 

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 18 of 18

Same locale? Language?

same windows decimal separator?

 

Python for AutoCAD, Python wrappers for ARX https://github.com/CEXT-Dan/PyRx

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Customer Advisory Groups


Autodesk Design & Make Report