Gelişim Harita İmar İnş. Ltd. Şti

30/05/2013

TKGM GENEL MÜDÜRÜ DİYARBAKIR ZİYARETİ

05/05/2013

27/04/2013

Diyarbakır 18. Grup Tasisi Kadastro Çalışmaları sırasında Arazide Bulundu.

27/04/2013

SEVGİLİ HARİTASEVERLER YENİ TESİS KADASTROSUNDA BÖYLE BİR YAPIYA NASIL TAPU VERİLİR.

20/04/2013

Diyarbakır 18. Grup Kadastro Yapım İşi

02/04/2013

Excel Makro Karşılaştırma
ac
Sayfa1 de Kesin koordinatlar olacak
Sayfa2 de ise eşleşme sunucu gelecek koordinatlar olacak
Görünüm kısmında Makro makro kaydet
yeni Gürünüm de makroyu durdur
yeni Gürünüm makro Düzenle de cıkan ekranda düzenle
makro sayfası gelecen içinde makroları sil buraya yazman gerekenler

Sub Makro1()
For i = 1 To 315
Sheets("Sayfa2").Range("a" & i).Select
aa = Sheets("Sayfa2").Range("a" & i).Text
ap = Sheets("Sayfa2").Range("b" & i).Text
For j = 1 To 720
aaa = Sheets("Sayfa1").Range("a" & j).Text
aap = Sheets("Sayfa1").Range("b" & j).Text
If aa = aaa And ap = aap Then
Sheets("Sayfa2").Range("c" & i).FormulaR1C1 = Sheets("Sayfa1").Range("c" & j).Text
Sheets("Sayfa2").Range("d" & i).FormulaR1C1 = Sheets("Sayfa1").Range("d" & j).Text
Sheets("Sayfa2").Range("e" & i).FormulaR1C1 = Sheets("Sayfa1").Range("e" & j).Text
Sheets("Sayfa2").Range("f" & i).FormulaR1C1 = Sheets("Sayfa1").Range("f" & j).Text
Sheets("Sayfa2").Range("g" & i).FormulaR1C1 = Sheets("Sayfa1").Range("g" & j).Text
Sheets("Sayfa2").Range("h" & i).FormulaR1C1 = Sheets("Sayfa1").Range("h" & j).Text
GoTo 10
End If
Next j
10
Next i
End Sub

anlamları

For i = 1 To 315 bu sayfa2 deki hangi satırda başlayip hangi satıra kadar olacağın yazıyon

Sheets("Sayfa2").Range("a" & i).Select sayfa2 nin a sına göre başlat diyon

aa = Sheets("Sayfa2").Range("a" & i).Text sayfa2 deki a yi

ap = Sheets("Sayfa2").Range("b" & i).Text sayfa 2 deki b yi

For j = 1 To 720 sayfa1 deki hangi satırda başlayip hangi satıra kadar olacağın yazıyon

aaa = Sheets("Sayfa1").Range("a" & j).Text sayfa1 deki a yi

aap = Sheets("Sayfa1").Range("b" & j).Text sayfa2 deki b yi

If aa = aaa And ap = aap Then bunu amacı ise eğer sayfa2 a ve b sayfa1 deki a ve b bir birini eşit ise
ozaman diyorki

Sheets("Sayfa2").Range("c" & i).FormulaR1C1 = Sheets("Sayfa1").Range("c" & j).Text

yane safya2 deki c sotuna sayfa1 deki c sotunun aynısı yaz diyorsun burda daha fazla sutun yazmak istiyorsan sotunları çoğunta bilirsin

Kadri BORA

12/03/2013

10/03/2013

' Yazan : Kadri BORA
' Tarih : 15.04.2012
' Açıklama : Çakışan çokludoğruları bulur ve tabakalarını değiştirir..

Sub Main
Dim i,j,coklu1,coklu2,sonuc,l,x,y,yeni
yeni = "CAKISMALAR"
With Netcad 'Netcad işlemleri arasından..
For i = 0 to .numobject - 2 'Süzülen nesneler arasında döngü başlatılıyor..
Set coklu1 = .getobject(i)
if coklu1.tag = opline then
Set coklu1 = coklu1.getObjectAsPline() 'Çokludoğru olduğunu işlemci de bilsin..
For j = i + 1 to .numobject - 1
sonuc = 0
Set coklu2 = .getobject(j)
if coklu2.tag = opline then
Set coklu2 = coklu2.getObjectAsPline() 'Çokludoğru olduğunu işlemci de bilsin..
if coklu1.num coklu2.num then sonuc = 0 else sonuc = 1 'Nokta sayıları eşit değilse kontrole gerek yok..
if sonuc = 1 then 'Nokta sayıları eşitse koordinatlar da aynı mı diye bakılacak..
For l = 0 to coklu1.num - 1
if coklu1.cor(l).x coklu2.cor(l).x then sonuc = 0
if coklu1.cor(l).y coklu2.cor(l).y then sonuc = 0
Next
End if
End if
if sonuc = 1 then
Set coklu2 = .getobject(j)
coklu2.tabaka = .createlayer(yeni,1) 'Çakışan alan bulunmuşsa tabakası değiştiriliyor..
.putobject j, coklu2
End if
Next
End if
Next
Set coklu1 = nothing 'RAM boşaltılıyor..
Set coklu2 = nothing 'RAM boşaltılıyor..
End With
End Sub

10/03/2013

' TARIH : 24.01.2012
' AMAÇ : Proje-Farklı Kaydet-DXF ile yazılan dxf dosyalarının
' Autocad ortamında açılmasında yaşanan sorunları giderir.
' NCZ dosyayı sorunsuz olarak saklanması için düzenler.
'
' GEREKLİLİKLER : NCMacro 4.0.015 ve üstü versiyon.
'
' HAZIRLAYAN : Kadri Bora
' NetCAD İstanbul Bölge Müdürlüğü
'
'
sub main
'obje Rengi2TabakaRengi
objCol2LayerCol
'Tabaka Rengi Kontrllü
setLayerColor
'Tabaka Adı Kontrolü
CorrectLayerNames
'Blok Adı Kontrolü
checkBlockNames
msgbox "Proje Düzenlendi..."
end sub

sub SetLayerColor
dim i,j
with nclayermanager
for i = 0 to .numlayer-1
if .layer(i).color = 80 or _
.layer(i).color = 15 or _
.layer(i).color = 0 or _
.layer(i).color = 16 then
.layer(i).color = 4
end if
next
end with
end sub

sub objCol2LayerCol
dim i,obj
with netcad
set obj = .getobject(i)
if obj.renk 0 then
obj.renk = 0
end if
set obj = nothing
end with
end sub

sub CorrectLayerNames
dim n,i
with nclayermanager
for i = 0 to .numlayer-1
n = ucase(.layer(i).name)
n = replace(n,"Ü","U")
n = replace(n,"Ğ","g")
n = replace(n,"İ","I")
n = replace(n,"ı","I")
n = replace(n,"Ş","s")
n = replace(n,"Ç","c")
n = replace(n,"Ö","o")
n = replace(n,".","_")
.layer(i).name = UCase(n)
next
end with
end sub

sub checkBlockNames
dim i,obj
with netcad
.setfilter nothing,array(),array(oblock)
set obj = .newobject
while .getnextobject2(obj)
if obj.pname = "" then
msgbox "İsimsiz Blok Var. Lütfen İsimsiz Olan Blok Objesine Bir İsim Veriniz..."
.resetFilter
exit sub
end if
wend
.resetfilter
end with
end sub