Microstation Mvba TextBorder

Type txtBorder
  gg As Long
  lineWeight As Integer
  color As Long
  level As String
End Type


Public tBorder As txtBorder

' ===============================================================================
Sub textBorder()
  Dim sScanEnumerator As ElementEnumerator
  Dim sElement As element
  Dim gg As Long
  Dim sFence As Fence
  tBorder.lineWeight = 4
  tBorder.color = 16
  tBorder.level = "Border"
  Set sFence = ActiveDesignFile.Fence
  If ActiveModelReference.AnyElementsSelected Or sFence.IsDefined Then
     If ActiveModelReference.AnyElementsSelected Then
        Set sScanEnumerator = ActiveModelReference.GetSelectedElements
     Else
        Set sScanEnumerator = sFence.GetContents
     End If
     ActiveModelReference.UnselectAllElements
     Do While sScanEnumerator.MoveNext
        Set sElement = sScanEnumerator.Current
        If sElement.Type = msdElementTypeText Or sElement.Type = msdElementTypeTextNode Then
           besuTextBorder sElement, tBorder
        End If
     Loop
  Else
     CommandState.StartLocate New classTextBorder
  End If
End Sub

Function besuTextBorder(sElement As element, tBorder As txtBorder)
   gg = UpdateGraphicGroupNumber 'CurrentGraphicGroup
   tBorder.gg = gg
    If sElement.Type = msdElementTypeTextNode Then
       dropElemTN sElement, tBorder
    End If
    If sElement.Type = msdElementTypeText Then
       dropElemT sElement, tBorder
    End If
    sElement.GraphicGroup = tBorder.gg
    sElement.Rewrite
End Function

' ===============================================================================
Function dropElemTN(oEle As element, tBorder As txtBorder)
    ShowStatus ""
    On Error GoTo NoElement
    If oEle.IsDroppableElement Then
        Dim oDE As DroppableElement
        Dim oEE As ElementEnumerator
        Set oDE = oEle
        Set oEE = oDE.Drop
        Do While oEE.MoveNext
            If oEE.Current.Type = msdElementTypeText Then
               dropElemT oEE.Current, tBorder.gg
            End If
        Loop
    End If
    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function

' ===============================================================================
Function dropElemT(oEle As element, tBorder As txtBorder)
    ShowStatus ""
    On Error GoTo NoElement
    If oEle.IsDroppableElement Then
        Dim oNew As element
        Dim oDE As DroppableElement
        Dim oEE As ElementEnumerator
        Set oDE = oEle
        Set oEE = oDE.Drop
        Do While oEE.MoveNext
            Set oNew = oEE.Current
            ActiveModelReference.AddElement oNew
            oNew.lineWeight = tBorder.lineWeight
            oNew.color = tBorder.color
            oNew.GraphicGroup = tBorder.gg
            oNew.level = besuLevel(tBorder.level & "_" & oEle.level.Name)
            oNew.Rewrite
            If oNew.IsClosedElement Then
               oNew.AsClosedElement.FillMode = msdFillModeNotFilled
               oNew.Rewrite
            End If
            If oNew.IsCellElement Then
               CellElem oNew.AsCellElement
            End If
        Loop
    End If

    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function

' ===============================================================================
Function CellElem(cEle As CellElement)
  Dim cComponents As ElementEnumerator
  On Error GoTo NoElement
  Set cComponents = cEle.GetSubElements
  Do While cComponents.MoveNext
    Dim cComponent As element
    Set cComponent = cComponents.Current
    If cComponent.IsClosedElement Then
       cComponent.AsClosedElement.FillMode = msdFillModeNotFilled
       cComponent.Rewrite
    End If
  Loop
  'cEle.Rewrite
    Exit Function
NoElement:
    ShowStatus "Element not found"
End Function






' ===============================================================================
Function besuLevel(levname As String) As level
   Set besuLevel = ActiveDesignFile.Levels.Find(levname)
   If besuLevel Is Nothing Then
      CadInputQueue.SendKeyin "level create " & Chr(34) & levname & Chr(34)
      'Set besuLevel = ActiveDesignFile.Levels.Find(levname)
   End If
   Set besuLevel = ActiveDesignFile.Levels.Find(levname)
End Function

class modülüne de alttaki kodlar yazılır. class modülünün ismi önemli

classTextBorder

Option Explicit
Implements ILocateCommandEvents

' ===============================================================================
' DATAPOINT HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Accept(ByVal element As element, point As Point3d, ByVal View As View)
    besuTextBorder element, tBorder
'    CommandState.StartPrimitive New classDrawValve
End Sub

' ===============================================================================
' CLEANUP HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Cleanup()

End Sub

' ===============================================================================
' DYNAMICS HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_Dynamics(point As Point3d, _
    ByVal View As View, ByVal DrawMode As MsdDrawingMode)
End Sub

' ===============================================================================
' LOCATE FAILED HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_LocateFailed()
    CommandState.StartLocate New classTextBorder
End Sub

' ===============================================================================
' LOCATE FILTER - lines only
' ===============================================================================
Private Sub ILocateCommandEvents_LocateFilter(ByVal element As element, _
    point As Point3d, Accepted As Boolean)
    Accepted = False
    If (element.IsTextElement) Or (element.IsTextNodeElement) Then
            Accepted = True
    End If
End Sub

' ===============================================================================
' RESET HANDLER
' ===============================================================================
Private Sub ILocateCommandEvents_LocateReset()
    CommandState.StartLocate New classTextBorder
'    CommandState.StartDefaultCommand
End Sub

' ===============================================================================
' LOCATE INITIALIZATION
' ===============================================================================
Private Sub ILocateCommandEvents_Start()
    Dim lc As LocateCriteria
    Set lc = CommandState.CreateLocateCriteria(False)
    CommandState.SetLocateCriteria lc
    CommandState.EnableAccuSnap
    ShowCommand "Place Component"
    ShowPrompt "Select Text or TextNode"
End Sub

kodları kod projemize ekledikten sonra
 vba run textBorder 

ile programı çalıştırıyoruz.

Microstation Vba Seçili elementleri cell oluşturma

Option Explicit

Function xy(x As Double, y As Double) As Point3d
    xy = Point3dFromXY(x, y)
End Function

Sub CreateOrphanCell()
    Dim eleCell As CellElement
    Dim vertices(0 To 3) As Point3d
    Dim ele(0 To 2) As Element
   
    Set ele(0) = CreateLineElement2(Nothing, xy(0, 5), xy(10, 5))
   
    vertices(0) = xy(0, 0)
    vertices(1) = xy(0, 7)
    vertices(2) = xy(10, 7)
    vertices(3) = xy(10, 0)
    Set ele(1) = CreateShapeElement1(Nothing, vertices, msdFillModeUseActive)
   
    Set ele(2) = CreateTextElement1(Nothing, "My Orphan Cell", xy(5, 6), Matrix3dIdentity)
   
    Set eleCell = CreateCellElement1(vbNullString, ele, xy(0, 0), False)
    eleCell.name = "OrphanCell"
    ActiveModelReference.AddElement eleCell
       
    eleCell.Redraw
End Sub

Sub secilileriCellYap()
  Dim ele() As Element
  Dim gElement As Element
  Dim eleCell As CellElement
  Dim oScanCriteria As ElementScanCriteria
  Dim oScanEnumerator As ElementEnumerator
  Dim eSay As Integer
  Dim aTags() As TagElement
  Dim tagIndex As Long
  If ActiveModelReference.AnyElementsSelected Then
     Set oScanEnumerator = ActiveModelReference.GetSelectedElements
  Else
     Dim sFence As Fence
     Set sFence = ActiveDesignFile.Fence
     If sFence.IsDefined Then Set oScanEnumerator = sFence.GetContents
  End If
  '     Set tElement = gElement.AsTextElement
  '     ActiveModelReference.AddElement tElement
  eSay = -1
  Do While oScanEnumerator.MoveNext
     Set gElement = oScanEnumerator.Current
     If gElement.IsGraphical Then
        eSay = eSay + 1
        ReDim Preserve ele(eSay)
        Set ele(eSay) = gElement
        aTags = gElement.GetTags
        For tagIndex = LBound(aTags) To UBound(aTags)
           Dim sourceTag As TagElement
           eSay = eSay + 1
           ReDim Preserve ele(eSay)
           Set sourceTag = aTags(tagIndex)
           Set ele(eSay) = sourceTag
           'ActiveDesignFile.Models(att).CopyElement sourceTag, oCC
        Next tagIndex
     End If
'     ActiveModelReference.RemoveElement gElement
   
  Loop
  Set eleCell = CreateCellElement1(vbNullString, ele, xy(0, 0), False)
  eleCell.name = "OrphanCell"
  ActiveModelReference.AddElement eleCell

End Sub

Kesim2019

DKTY KESİM MERKEZİ

2019 yılı

KNO	DURUM	KESIM SAAT	MASA SAAT	MASA NO	TESLIM SAAT

Kurban Kesim Takip Programı Excel

Kurban Kesim Takip Programı;
Büyükbaş kurban kesimi takibi için ecxelde oluşturulmuş bir programdır.

Hayr için kullanacaklara kullanım serbesttir.

Excelde Kesim takibi

Programın calışması icin Office - Excelin 32 bit olması gerekir. 

Windows 64 olabilir.

32 bit office kurulduğundan emin isenizi  alttaki dosyaları indirip programı kullanabilirsiniz.

indirilen dosyaları c:\temp   içine kopyala (yoksa oluşturulur)

sağ tuş ile buraya çıkar denilir. ocx diye bir dizin oluşacak birde reg_kesim.bat dosyası olacak
reg_kesim.bat dosyası sağ tuş ile yönetici olarak çalıştırılır.

Yandaki gibi mesaj çıkması lazım

Acılışta Güvenlik Uyarısı olarak Macrolar devre dışı bırakıldı diyor ise Seceneklerden icerik etkinleştirilir.

Yardım almak isteyenler telden bana ulaşabilirler. Dosyanın Ana Sayfasında telefon numaram mevcut.

Bilgisayardan destek almak isteyenler olursa musait olursam Teamviewer ile  uzak masa üstü yardımı verebilirim.

---------------------------------------------------------------------------------------

Kesim takip flash dosyası SWF 2019 indir
SWF dosyasının çalışması için FlashPlayer indir

Kesim takip Excel ve ocx dosyaları 2020 indir

rar lı dosyaların şifreleri videoda mevcuttur.

şifreleri görmek için youtube ekranında altyazıların açık olması lazım

Kurban Kesiminde canlı yayın

Kurban Satış Takip Programı 2019

Kurban Satış Takip Programı;
Büyükbaş kurban satışları için ecxelde oluşturulmuş bir programdır.

Excelde hisse satışı için kurbanlıklar veritabanına aktarıldıktan sonra
Ana Sayfa da Hisse Satışı ile yapılabilir.

Üst bölümde kurbanlıklar
Alt bölümde hissedarlar mevcuttur.

Büyükbaş kurban satışları için kullanılabilecek Excelde oluşturulmuş bir programdır.

Excelde Hisse satışı,

Programın calışması icin Office - Excelin 32 bit olması gerekir. 

Windows 64 olabilir.

32 bit office kurulduğundan emin iseniz eklenti dosyaları indirilip sisteme register edilmelidir.

kurbaneklenti.rar dosyası c:\temp   içine kopyala (yoksa oluşturulur)

sağ tuş ile buraya çıkar denilir. ocx diye bir dizin oluşacak birde reg_kurban.bat dosyası olacak
reg_kurban.bat dosyası sağ tuş ile yönetici olarak çalıştırılır.

Yandaki gibi mesaj çıkması lazım

kurbansatis2019.rar da excel ve veritabanı dosyaları mecut. onlarıda herhangi biryere çıkartalım.

Acılışta Güvenlik Uyarısı olarak Macrolar devre dışı bırakıldı diyor ise Seceneklerden icerik etkinleştirilir.

Yardım almak isteyenler telden bana ulaşabilirler. Dosyanın Ana Sayfasında telefon numaram mevcut.

Bilgisayardan destek almak isteyenler alttaki programı (Teamviewer Portable versyonu) indirip (rar) lı dosyayı biryere acıp Teamviewer.exe yi calıştırarak  uzak masa üstü yardımı verebilirim.

---------------------------------------------------------------------------------------

Excel dosyasını  indir

Kesim takip flash dosyası drive dan indir

Kesim takip flash dosyası EXE indir
Kesim takip flash dosyası SWF indir
SWF dosyasının çalışması için FlashPlayer indir

---------------------------------------------------------------------------------------

Uzaktan Yardım Programı indir

Kurban Kesiminde canlı yayın