Prograss bar ilerleme hızının makro ile uyumu

cocoa35 · 1 Mayıs 2018

Merhabalar; Ek'teki örnek "Döviz deneme" dosyasında , userform vasıtası ile TCMB 'den döviz kurlarını istediğim tarihe göre alan bir makro çalışmam mevcut.
Benim yaptırmak istediğim userform1 üstünde bulunan progressbar'ın makro ile uyumlu çalışmasını sağlamak.
yani ben command button'a tıkladığımda progressbar çalışmaya başlasın vede döviz kurları sayfaya yazıldığı anda %100 'e ulaşsın.
şu andaki örnek'te progressbar çok çabuk %100'e ulaşıyor. yani makro ile uyumlu çalışmıyor.
Bu konuda yardımcı olurmusunuz lütfen.

halit3 · 1 Mayıs 2018

Bu hesaplama aynı şekilde ahenkle gitmesi için süreyi önceden hesaplaması lazım kod iki kere çalışması lazım birincisinde süreyi hesaplaması gerekiyor sonrada ikincisinde bu süreyi nesneye adepte etmek gerekiyor.

Farklı bir yaklaşımla api li kod veriyorum siz kırmızı yerdeki değeri oynayınız.

Kod:

Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long)

Private Sub CommandButton2_Click()
Sayfa1.Range("A2").Value = TextBox1.Text
For j = 1 To 10
Sleep [COLOR="Red"]350[/COLOR]
i = i + [COLOR="Red"]10[/COLOR]
ProgressBar1.Value = i
Next j
End Sub

cocoa35 · 1 Mayıs 2018

Sayın halit3 bey çok teşekkür ederim vermiş olduğunuz kod'u uyguladım, ancak bu sefer macro bitip sayfaya döviz rakkamı yazıldıktan sonra progressbar çalışmaya başlıyor.
Sizden rica etsem eklemiş olduğum, Döviz deneme dosyasına siz kod'u ekleyip gönderebilirmisiniz acaba ? çünkü ben yanlış uyguladım sanırım.
Teşekkür ederim.

halit3 · 1 Mayıs 2018

Modül1 eklediğim bölümü kırmızı ile belirttim

Kod:

Option Explicit
[COLOR="Red"]Dim say[/COLOR]
Enum xKurTip
    xForexBuying = 0
    xForexSelling = 1
    xBanknoteBuying = 2
    xBanknoteSelling = 3

End Enum
[COLOR="red"]Sub saydırma()
say = 0
End Sub[/COLOR]

Function KurSorgula(xKurKod As String, Optional xTarih As Date, Optional KurTipi As xKurTip = xForexBuying) As Double
    
[COLOR="red"]    say = say + 2
    If say > 100 Then say = 100
    UserForm1.ProgressBar1.Value = say[/COLOR]
    
    Const xmlURL1 = "http://tcmb.gov.tr/kurlar/today.xml"
    Const xmlURL2 = "http://www.tcmb.gov.tr/kurlar/%p1/%p2.xml"
    Dim xmlTCMB
    Dim xmlNODE
    Dim xmlURL As String
    Dim Sor
    If IsEmpty(xTarih) Or xTarih = #12:00:00 AM# Then
        xTarih = Date
    End If
    If xTarih >= Date Then
        xmlURL = xmlURL1
    Else
        xmlURL = Replace(Replace(xmlURL2, "%p1", Format(xTarih - 1, "yyyymm")), "%p2", Format(xTarih - 1, "ddmmyyyy"))
    End If
    Do Until XMLVarmi(xmlURL)
        If xmlURL <> xmlURL1 Then
            xTarih = xTarih - 1
            If xTarih < #6/18/2002# Then GoTo Hata
            xmlURL = Replace(Replace(xmlURL2, "%p1", Format(xTarih, "yyyymm")), "%p2", Format(xTarih, "ddmmyyyy"))
        Else
            GoTo Hata
        End If
        DoEvents
    Loop
    Set xmlTCMB = CreateObject("MSXML2.DOMDocument.6.0")
    xmlTCMB.Load xmlURL
    Do
        DoEvents
    Loop Until xmlTCMB.parsed = True
    Set xmlNODE = xmlTCMB.SelectNodes("Tarih_Date/Currency[@Kod='" & xKurKod & "'][BanknoteBuying>0]")
    Select Case KurTipi
        Case xForexBuying
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("ForexBuying").Item(0).Text) ', ".", Application.DecimalSeparator))
        Case xForexSelling
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("ForexSelling").Item(0).Text) ', ".", Application.DecimalSeparator))
        Case xBanknoteBuying
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("BanknoteBuying").Item(0).Text) ', ".", Application.DecimalSeparator))
        Case xBanknoteSelling
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("BanknoteSelling").Item(0).Text) ', ".", Application.DecimalSeparator))
    End Select
    Set xmlTCMB = Nothing
    Set xmlNODE = Nothing
    Exit Function
Hata:
    Set xmlTCMB = Nothing
    Set xmlNODE = Nothing
    KurSorgula = "Yok"
End Function

Private Function XMLVarmi(URL As String) As Boolean

    Dim HTTPBaglanti As Object
    Set HTTPBaglanti = CreateObject("WinHttp.WinHttpRequest.5.1")
    On Error GoTo XMLVarmi_Error
    HTTPBaglanti.Open "GET", URL
    HTTPBaglanti.send
    If HTTPBaglanti.Status = 200 Then
        XMLVarmi = True
    Else
        XMLVarmi = False
    End If
    Set HTTPBaglanti = Nothing
    Exit Function
XMLVarmi_Error:
    Set HTTPBaglanti = Nothing
    XMLVarmi = False
End Function

userforma da bu kodu ekle

Kod:

Private Sub CommandButton2_Click()
saydırma
ProgressBar1.Value = 0.1
Sayfa1.Range("A2").Value = TextBox1.Text
End Sub

cocoa35 · 2 Mayıs 2018

Sayın Halit bey; yapmış olduğunuz çalışma için çok teşekkür ederim tam istediğim gibi oldu, iyi'ki sizler varsınız..bir kez daha teşekkürler.

halit3 · 2 Mayıs 2018

Bu dosya birazcık daha iyi oldu
Burada 100 sayısını formüllü satırların toplamını buluyoruz ve bölüyoruz

Kod:

Option Explicit
[COLOR="Red"]Dim say
Dim ekle1[/COLOR]
Enum xKurTip
    xForexBuying = 0
    xForexSelling = 1
    xBanknoteBuying = 2
    xBanknoteSelling = 3

End Enum
[COLOR="red"]Sub saydırma()
On Error Resume Next
Dim objRange As Range
Set objRange = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
If Not objRange Is Nothing Then
ekle1 = 100 / CStr(objRange.Cells.Count)
Else
ekle1 = 2
End If
Set objRange = Nothing
say = 0
End Sub[/COLOR]


Function KurSorgula(xKurKod As String, Optional xTarih As Date, Optional KurTipi As xKurTip = xForexBuying) As Double
    
[COLOR="red"]    say = say + ekle1
    If say > 100 Then say = 100
    UserForm1.ProgressBar1.Value = say[/COLOR]
  
    
    Const xmlURL1 = "http://tcmb.gov.tr/kurlar/today.xml"
    Const xmlURL2 = "http://www.tcmb.gov.tr/kurlar/%p1/%p2.xml"
    Dim xmlTCMB
    Dim xmlNODE
    Dim xmlURL As String
    Dim Sor
    If IsEmpty(xTarih) Or xTarih = #12:00:00 AM# Then
        xTarih = Date
    End If
    If xTarih >= Date Then
        xmlURL = xmlURL1
    Else
        xmlURL = Replace(Replace(xmlURL2, "%p1", Format(xTarih - 1, "yyyymm")), "%p2", Format(xTarih - 1, "ddmmyyyy"))
    End If
    Do Until XMLVarmi(xmlURL)
        If xmlURL <> xmlURL1 Then
            xTarih = xTarih - 1
            If xTarih < #6/18/2002# Then GoTo Hata
            xmlURL = Replace(Replace(xmlURL2, "%p1", Format(xTarih, "yyyymm")), "%p2", Format(xTarih, "ddmmyyyy"))
        Else
            GoTo Hata
        End If
        DoEvents
    Loop
    Set xmlTCMB = CreateObject("MSXML2.DOMDocument.6.0")
    xmlTCMB.Load xmlURL
    Do
        DoEvents
    Loop Until xmlTCMB.parsed = True
    Set xmlNODE = xmlTCMB.SelectNodes("Tarih_Date/Currency[@Kod='" & xKurKod & "'][BanknoteBuying>0]")
    Select Case KurTipi
        Case xForexBuying
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("ForexBuying").Item(0).Text) ', ".", Application.DecimalSeparator))
        Case xForexSelling
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("ForexSelling").Item(0).Text) ', ".", Application.DecimalSeparator))
        Case xBanknoteBuying
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("BanknoteBuying").Item(0).Text) ', ".", Application.DecimalSeparator))
        Case xBanknoteSelling
            KurSorgula = Val(xmlNODE.Item(0).SelectNodes("BanknoteSelling").Item(0).Text) ', ".", Application.DecimalSeparator))
    End Select
    Set xmlTCMB = Nothing
    Set xmlNODE = Nothing
    Exit Function
Hata:
    Set xmlTCMB = Nothing
    Set xmlNODE = Nothing
    KurSorgula = "Yok"
End Function

cocoa35 · 2 Mayıs 2018

Sayın Halit bey;
Yeni kod'lar için tekrar teşekkürler, ben biraz yüzsüzlük yapıp userform üstünde işlem srasınca rakkamsal ilerlemenin gözükmesinide istiyorum " % " olarak bunun için Label ekledim ama direk % 100 yazıyor. bunu ilerleme şeklinde yapabilirmisiniz.
Teşekkürler;

halit3 · 2 Mayıs 2018

dosyayı irdeleyiniz.

cocoa35 · 2 Mayıs 2018

Çok teşekkür ederim Halit bey gayet iyi olmuş..

halit3 · 3 Mayıs 2018

Önceki kodda sayfada ne kadar formül varsa hepsini sayıyordu şimdi herhalde doğrusu oldu galiba

Bu dosyada KTF tanımlı "KurSorgula" fonksiyonunu sayma işlemi yapıyor

Kod:

Sub saydırma()
On Error GoTo atla
Dim aranan
say = 0
Dim cell As Range
aranan = "=KurSorgula"
For Each cell In ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas).Cells
If Mid(cell.Formula, 1, Len(aranan)) = aranan Then
say = say + 1
End If
Next cell
atla:
If say > 0 Then
ekle1 = 100 / say
Else
ekle1 = 2
End If
say = 0
End Sub

cocoa35 · 7 Mayıs 2018

Halit bey; iyi günler döviz sorgulama progressbar harika oldu bir kez daha teşekkürlerimi sunmak istiyorum.Ayrıca eğer mümkünse ek'te bulunan AutoCad'e koordinat çizdirme makro'yada ProgressBar eklemek istiyorum.
Ben uğraştım ama yapamadım , siz üstadlarımızın yardımına ihtiyacımız var.Teşekkürler.

halit3 · 7 Mayıs 2018

Evvelce farklı konu başlığı altında bu sorunuza bakmıştım. Ben ofis 2003 kullanıyorum eklediğin dosya bende çalışmıyor.

derisa963 · 8 Mayıs 2018

halit3' Alıntı:
Bu hesaplama aynı şekilde ahenkle gitmesi için süreyi önceden hesaplaması lazım kod iki kere çalışması lazım birincisinde süreyi hesaplaması gerekiyor sonrada ikincisinde bu süreyi nesneye adepte etmek gerekiyor.

Farklı bir yaklaşımla api li kod veriyorum siz kırmızı yerdeki değeri oynayınız.

Kod:

Private Declare Sub Sleep Lib "kernel32" (ByVal milliseconds As Long) Private Sub CommandButton2_Click() Sayfa1.Range("A2").Value = TextBox1.Text For j = 1 To 10 Sleep [COLOR="Red"]350[/COLOR] i = i + [COLOR="Red"]10[/COLOR] ProgressBar1.Value = i Next j End Sub

Merhabalar Süreyi ölçmek için şu yolu izleyebilirsinizn

Sub zaman_hesapla()
Dim zaman, gecen_zaman As Double
zaman = Timer

'KODLARINIZ
'
'
'
gecen_zaman = Timer - zaman
MsgBox ("Kod Hesaplamasında Geçen Süre : " & Format(gecen_zaman, "0.00") & " Saniye."), vbQuestion, "MESAJ"
End Sub

cocoa35 · 8 Mayıs 2018

Halit bey; Ben Kodları size vereyim
Modül içinde olan kod'lar;

Sub KoordinatCizimi()

On Error GoTo Hata

Dim koordinat
Dim xkoordinat
Dim ykoordinat
Dim cizgi1
Dim cizgi2
Dim cizgi3
Dim cizgi4
Dim cizgi5
Dim cizgi6
Dim cizgi7
Dim cizgi8
Dim cizgi9
Dim cizgi10
Dim cizgi11
Dim cizgi12
Dim cizgi13
Dim cizgi14
Dim cizgi15
Dim cizgi16
Dim cizgi17
Dim cizgi18
Dim cizgi19
Dim cizgi20
Dim cizgi21
Dim cizgi22
Dim cizgi23
Dim cizgi24
Dim cizgi25
Dim cizgi26
Dim cizgi27
Dim cizgi28
Dim cizgi29
Dim cizgi30
Dim cizgi31
Dim cizgi32
Dim cizgi33
Dim cizgi34
Dim cizgi35
Dim cizgi36
Dim cizgi37
Dim cizgi38
Dim cizgi39
Dim cizgi40

Dim Secim As Range

Set Secim = Application.InputBox(Prompt:="İLK(X)Koordinatı Fare ile seçiniz. ÖRNEK: $A$2 veya A2" & vbCrLf & _
vbCrLf & "* Y koordinatı Belirlediniz (X)hücrenin yanındaki Sütun olacaktır" & vbCrLf & _
"* Z koordinatı Sıfır(0) kabul edilecektir.", Title:="İlk X Koordinatını Seçiniz", Type:=8)

Range(Secim.Address(False, False)).Select

Application.ScreenUpdating = False

Do While Not IsEmpty(ActiveCell)

xkoordinat = Replace(ActiveCell.Value, ",", ".")
koordinat = koordinat & xkoordinat & ","

ActiveCell.Offset(0, 1).Activate

ykoordinat = Replace(ActiveCell.Value, ",", ".")

If ykoordinat = "" Then
ykoordinat = 0
End If

koordinat = koordinat & ykoordinat & ",0 "
ActiveCell.Offset(1, -1).Activate

Loop
cizgi1 = Range("D42").Value & "," & Range("E42").Value & " " & Range("F42").Value & "," & Range("G42").Value & " "
cizgi2 = Range("D43").Value & "," & Range("E43").Value & " " & Range("F43").Value & "," & Range("G43").Value & " "
cizgi3 = Range("D44").Value & "," & Range("E44").Value & " " & Range("F44").Value & "," & Range("G44").Value & " "
cizgi4 = Range("D45").Value & "," & Range("E45").Value & " " & Range("F45").Value & "," & Range("G45").Value & " "
cizgi5 = Range("D33").Value & "," & Range("E33").Value & " " & Range("F33").Value & "," & Range("G33").Value & " "
cizgi6 = Range("D34").Value & "," & Range("E34").Value & " " & Range("F34").Value & "," & Range("G34").Value & " "
cizgi7 = Range("D35").Value & "," & Range("E35").Value & " " & Range("F35").Value & "," & Range("G35").Value & " "
cizgi8 = Range("D36").Value & "," & Range("E36").Value & " " & Range("F36").Value & "," & Range("G36").Value & " "
cizgi9 = Range("D37").Value & "," & Range("E37").Value & " " & Range("F37").Value & "," & Range("G37").Value & " "
cizgi10 = Range("D38").Value & "," & Range("E38").Value & " " & Range("F38").Value & "," & Range("G38").Value & " "
cizgi11 = Range("D39").Value & "," & Range("E39").Value & " " & Range("F39").Value & "," & Range("G39").Value & " "
cizgi12 = Range("D40").Value & "," & Range("E40").Value & " " & Range("F40").Value & "," & Range("G40").Value & " "
cizgi13 = Range("D41").Value & "," & Range("E41").Value & " " & Range("F41").Value & "," & Range("G41").Value & " "
cizgi14 = Range("D42").Value & "," & Range("E42").Value & " " & Range("F42").Value & "," & Range("G42").Value & " "
cizgi15 = Range("D43").Value & "," & Range("E43").Value & " " & Range("F43").Value & "," & Range("G43").Value & " "
cizgi16 = Range("D44").Value & "," & Range("E44").Value & " " & Range("F44").Value & "," & Range("G44").Value & " "
cizgi17 = Range("D45").Value & "," & Range("E45").Value & " " & Range("F45").Value & "," & Range("G45").Value & " "
cizgi18 = Range("D46").Value & "," & Range("E46").Value & " " & Range("F46").Value & "," & Range("G46").Value & " "
cizgi19 = Range("D47").Value & "," & Range("E47").Value & " " & Range("F47").Value & "," & Range("G47").Value & " "
cizgi20 = Range("D48").Value & "," & Range("E48").Value & " " & Range("F48").Value & "," & Range("G48").Value & " "
cizgi21 = Range("D49").Value & "," & Range("E49").Value & " " & Range("F49").Value & "," & Range("G49").Value & " " & Range("H49").Value & "," & Range("I49").Value & " "
cizgi22 = Range("D50").Value & "," & Range("E50").Value & " " & Range("F50").Value & "," & Range("G50").Value & " " & Range("H50").Value & "," & Range("I50").Value & " "
cizgi23 = Range("D51").Value & "," & Range("E51").Value & " " & Range("F51").Value & "," & Range("G51").Value & " " & Range("H51").Value & "," & Range("I51").Value & " "
cizgi24 = Range("D52").Value & "," & Range("E52").Value & " " & Range("F52").Value & "," & Range("G52").Value & " " & Range("H52").Value & "," & Range("I52").Value & " "
cizgi25 = Range("D53").Value & "," & Range("E53").Value & " " & Range("F53").Value & "," & Range("G53").Value & " " & Range("H53").Value & "," & Range("I53").Value & " "
cizgi26 = Range("D54").Value & "," & Range("E54").Value & " " & Range("F54").Value & "," & Range("G54").Value & " " & Range("H54").Value & "," & Range("I54").Value & " "
cizgi27 = Range("D55").Value & "," & Range("E55").Value & " " & Range("F55").Value & "," & Range("G55").Value & " " & Range("H55").Value & "," & Range("I55").Value & " "
cizgi28 = Range("D56").Value & "," & Range("E56").Value & " " & Range("F56").Value & "," & Range("G56").Value & " " & Range("H56").Value & "," & Range("I56").Value & " "
cizgi29 = Range("D57").Value & "," & Range("E57").Value & " " & Range("F57").Value & "," & Range("G57").Value & " " & Range("H57").Value & "," & Range("I57").Value & " "
cizgi30 = Range("D58").Value & "," & Range("E58").Value & " " & Range("F58").Value & "," & Range("G58").Value & " " & Range("H58").Value & "," & Range("I58").Value & " "
cizgi31 = Range("D59").Value & "," & Range("E59").Value & " " & Range("F59").Value & "," & Range("G59").Value & " " & Range("H59").Value & "," & Range("I59").Value & " "
cizgi32 = Range("D60").Value & "," & Range("E60").Value & " " & Range("F60").Value & "," & Range("G60").Value & " " & Range("H60").Value & "," & Range("I60").Value & " "
cizgi33 = Range("D61").Value & "," & Range("E61").Value & " " & Range("F61").Value & "," & Range("G61").Value & " " & Range("H61").Value & "," & Range("I61").Value & " "
cizgi34 = Range("D62").Value & "," & Range("E62").Value & " " & Range("F62").Value & "," & Range("G62").Value & " " & Range("H62").Value & "," & Range("I62").Value & " "
cizgi35 = Range("D63").Value & "," & Range("E63").Value & " " & Range("F63").Value & "," & Range("G63").Value & " " & Range("H63").Value & "," & Range("I63").Value & " "
cizgi36 = Range("D64").Value & "," & Range("E64").Value & " " & Range("F64").Value & "," & Range("G64").Value & " " & Range("H64").Value & "," & Range("I64").Value & " "
cizgi37 = Range("D65").Value & "," & Range("E65").Value & " " & Range("F65").Value & "," & Range("G65").Value & " " & Range("H65").Value & "," & Range("I65").Value & " "
cizgi38 = Range("D66").Value & "," & Range("E66").Value & " " & Range("F66").Value & "," & Range("G66").Value & " " & Range("H66").Value & "," & Range("I66").Value & " "
cizgi39 = Range("D67").Value & "," & Range("E67").Value & " " & Range("F67").Value & "," & Range("G67").Value & " " & Range("H67").Value & "," & Range("I67").Value & " "
cizgi40 = Range("D68").Value & "," & Range("E68").Value & " " & Range("F68").Value & "," & Range("G68").Value & " " & Range("H68").Value & "," & Range("I68").Value & " "

Range(Secim.Address(False, False)).Select

Application.ScreenUpdating = True

Dim Cad As AutoCAD.AcadApplication

Set Cad = New AutoCAD.AcadApplication

Cad.Application.ActiveDocument.SaveAs ActiveWorkbook.Path & "/" & _
Replace(ActiveWorkbook.Name, ".xlsm", ".dwg")

Cad.Visible = True
Cad.Application.WindowState = acMax

Cad.ActiveDocument.SendCommand "Line " & koordinat & " "
Cad.ActiveDocument.SendCommand "circle " & cizgi1 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi2 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi3 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi4 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi5 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi6 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi7 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi8 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi9 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi10 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi11 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi12 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi13 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi14 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi15 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi16 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi17 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi18 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi19 & Chr(27)
Cad.ActiveDocument.SendCommand "circle " & cizgi20 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi21 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi22 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi23 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi24 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi25 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi26 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi27 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi28 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi29 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi30 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi31 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi32 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi33 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi34 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi35 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi36 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi37 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi38 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi39 & Chr(27)
Cad.ActiveDocument.SendCommand "arc " & cizgi40 & Chr(27)

Cad.ActiveDocument.SendCommand "Zoom Extents "

Cad.Application.ActiveDocument.Save

Set Cad = Nothing
Hata:
Exit Sub

End Sub

UserForm'da olan kodlar;

Private Sub UserForm_Initialize()
saydırma
ProgressBar1.Value = 0.1
Unload Me
End Sub

cocoa35 · 8 Mayıs 2018

UserForm şu şekilde;

halit3 · 8 Mayıs 2018

Dosyadaki kodlara ulaşabiliyorum ancak dosyanız benim bilgisayarda çalışmıyor.

Kod:

Dim Cad As AutoCAD.AcadApplication

burada hata veriyor AutoCAD nesnesi veya dll bilgisayarda yok

cocoa35 · 8 Mayıs 2018

halit bey mrb. bilgisayarınızda yüklü olan autocad varmı? varsa tarihi kaç örneğin autocad2013 yüklü ise bunun programa tanıtılması gerekiyor.
bu işlem için
"Geliştirici/Visual Basic/Tools/References/AutoCad 2013 Type Library " kutucuğu işaretleyip ok dedinizmi program çalışacaktır.
Eğer Bilgisayarınızda AutoCad yüklü değilse program çalışmaz.

halit3 · 8 Mayıs 2018

Kod:

Geliştirici/Visual Basic/Tools/References/[COLOR="Red"]AutoCad 2013 Type Library [/COLOR]"

Bu bölüm benim bilgisayarda yok

cocoa35 · 8 Mayıs 2018

Halit bey; Bilgisayarınızda AutoCad yüklümü?

halit3 · 8 Mayıs 2018

Yüklü değil

14 nolu mesajınızdaki kodları silin gereksiz olarak duruyor

Prograss bar ilerleme hızının makro ile uyumu

cocoa35

Ekli dosyalar

halit3

Uzman

cocoa35

halit3

Uzman

Ekli dosyalar

cocoa35

halit3

Uzman

Ekli dosyalar

cocoa35

Ekli dosyalar

halit3

Uzman

Ekli dosyalar

cocoa35

halit3

Uzman

Ekli dosyalar

cocoa35

Ekli dosyalar

halit3

Uzman

derisa963

cocoa35

cocoa35

Ekli dosyalar

halit3

Uzman

cocoa35

halit3

Uzman

cocoa35

halit3

Uzman