' makro zjistujici delku jednolivych netu a pocet prokovu na netu v celem designu,
' lze vyexportovat do excelu a vybrat prislusny net v designu
Option Explicit
' definice konstant potrebnych pro zmenu fontu
Const LOGPIXELSY = 90
Const WM_SETFONT = &H30
' deklarace funkci potrebnych pro zmenu fontu
Declare Function CreateFontA Lib "gdi32" ( _
ByVal nHeight As Long, _
ByVal nWidth As Long, _
ByVal nEscapement As Long, _
ByVal nOrientation As Long, _
ByVal fnWeight As Long, _
ByVal fdwItalic As Long, _
ByVal fdwUnderline As Long, _
ByVal fdwStrikeOut As Long, _
ByVal fdwCharSet As Long, _
ByVal fdwOutputPrecision As Long, _
ByVal fdwClipPrecision As Long, _
ByVal fdwQuality As Long, _
ByVal fdwPitchAndFamily As Long, _
ByVal lpszFace As String _
) As Long
Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long _
) As Long
Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal nIndex As Long _
) As Long
Declare Function GetDlgItem Lib "user32" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long _
) As Long
Declare Function GetWindowDC Lib "user32" ( _
ByVal hWnd As Long _
) As Long
Declare Function ReleaseDC Lib "user32" ( _
ByVal hWnd As Long, _
ByVal hDC As Long _
) As Long
Declare Function SendMessageA Lib "user32" ( _
ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long _
) As Long
'deklarace promennych
Dim hFont As Long ' pro zmenu fontu
Dim SelNet As Boolean ' true = budeme vybirat nety v designu
Dim Sort As String ' urcuje, podle ceho se bude tridit
Sub Main
'alokace pole pro vlastnosti netu (dynamicke pole)
ReDim ListNetsName$(ActiveDocument.Nets.Count) ' pole pro jmeno netu
ReDim ListNetsLength(ActiveDocument.Nets.Count) ' pole pro delku netu
ReDim ListNetsVias(ActiveDocument.Nets.Count) ' pole pro pocet via na netu
ReDim ListNets$(ActiveDocument.Nets.Count) ' stringove pole vsech vlastnosti dohromady v poradi jmeno, delka, pocet via
FillArray
InfosToStringArray
'zmena fontu na Courier (fixfont)
Dim hDC As Long
hDC = GetWindowDC(0)
Dim Height As Long
Height = 36*GetDeviceCaps(hDC,LOGPIXELSY)/250
ReleaseDC 0,hDC
hFont = CreateFontA(Height,0,0,0,0,0,0,0,0,0,0,0,0,"Courier")
Begin Dialog UserDialog 500,210,"Length And vias",.CallbackFunc ' %GRID:10,7,1,1
CheckBox 350,147,100,14,"Select net",.Check
CancelButton 30,154,110,21
ListBox 20,21,450,112,ListNets(),.ListBox
Text 20,7,90,14,"Name:",.Text1
Text 170,7,90,14,"Length:",.Text2
Text 300,7,90,14,"Vias:",.Text3
PushButton 30,182,110,21,"To Excel",.PushButton1
PushButton 190,182,110,21,"Refresh",.Refresh
End Dialog
Dim dlg As UserDialog
SelNet=True
dlg.Check=1 'prepinac nastav na select
Dialog dlg
' po ukonceni programu smaz zmeneny font
DeleteObject hFont
End Sub
Sub FillArray
'nacteni informaci o netech do info poli
Dim i As Integer
i = 0
Dim NextNet As Object
For Each NextNet In ActiveDocument.Nets
ListNetsName(i)=NextNet.Name
ListNetsLength(i)=NextNet.Length(True)
ListNetsVias(i)=NextNet.Vias.Count
i=i+1
Next NextNet
End Sub
Sub InfosToStringArray
' slozi informacni pole do jednoho stringoveho pole
Dim i As Integer
For i=0 To ActiveDocument.Nets.Count-1
ListNets$(i)=AddSpace(ListNetsName(i))+AddSpace(Str(Int(ListNetsLength(i))))+ListNetsVias(i)
Next
End Sub
'doplni string mezerami na 15 znaku
Function AddSpace$(data$)
Dim NumSpace As Integer
NumSpace=15 - Len(data$)
AddSpace=data+Space$(NumSpace)
End Function
'vyjme z prvnich 15 znaku stringu pocatecni zaznam
Function SepareNameNet$(data$)
Dim Pom2 As String
Dim i As Integer
SepareNameNet$=""
Pom2$=Left(data$,15)
For i=1 To 15
If Mid$(Pom2$,i,1)<>" " Then
SepareNameNet$=SepareNameNet$+Mid$(Pom2$,i,1)
End If
Next i
End Function
' vlastni funkce dialogu
Function CallbackFunc%(DlgItem$, Action%, SuppValue%)
Dim Pom As Variant
Select Case Action%
Case 1 ' zde probiha inicializace dialog boxu
' menime font v listboxu
Dim hWnd As Long
hWnd = GetDlgItem(SuppValue,DlgControlId("ListBox"))
SendMessageA hWnd,WM_SETFONT,hFont,1
Case 2 'stisknuto nejake tlacitko, nebo neco vybrano v boxech
If DlgItem$="ListBox" Then ' vybrali jsme radku v boxu ListBox
If SelNet Then
' deselectuj vsechny objekty
ActiveDocument.SelectObjects(ppcbObjectTypeAll,"",False)
'selectuj vybrany net
ActiveDocument.SelectObjects(ppcbObjectTypeNet,SepareNameNet$(ListNetsName$(SuppValue%)),True)
End If
End If
' vybirame, zda se budou draty vybirat, ci nikoli
If DlgItem$="Check" Then
If SuppValue%=1 Then SelNet=True
If SuppValue%=0 Then SelNet=False
End If
' export do excelu
If DlgItem$="PushButton1" Then pom=InfoToExcel
If DlgItem$="Cancel" Then End
' refresh udaju v listboxu
If DlgItem$="Refresh" Then
CallBackFunc%=True
FillArray
InfosToStringArray
DlgListBoxArray "ListBox",ListNets()
End If
Case 4
Debug.Print"focus"
End Select
End Function
Function InfoToExcel
Dim FileName As Variant
Dim i As Integer
' Open temporarly text file
Randomize
filename = DefaultFilePath & "\tmp" & CInt(Rnd()*10000) & ".txt"
Open filename For Output As #1
' Output Headers
Print #1, "NetName"; Space(50);
Print #1, "NetLength"; Space(50);
Print #1, "Vias"; Space(0)
' Lock server to speed up process
LockServer
' Go through each component in the design and output values
For i=0 To ActiveDocument.Nets.Count
Print #1, ActiveDocument.Nets.Name; Space$(50-Len(ActiveDocument.Nets.Name));
Print #1, Str(Int(ActiveDocument.Nets.Length(True))); Space$(50-Len((Str(Int(ActiveDocument.Nets.Length)))));
Print #1, ActiveDocument.Nets.Vias.Count; Space$(50-Len(ActiveDocument.Nets.Vias.Count))
Next i
' Unlock the server
UnlockServer
' Close the text file
Close #1
' Start Excel and loads the text file
On Error GoTo noExcel
Dim excelApp As Object
Set excelApp = CreateObject("Excel.Application")
On Error GoTo 0
excelApp.Visible = True
excelApp.Workbooks.OpenText FileName:= filename
excelApp.Rows("1:1").Select
With excelApp.Selection
.Font.Bold = True
.Font.Italic = True
End With
excelApp.Range("A1").Select
Set excelApp = Nothing
End
noExcel:
' Display the text file
Shell "Notepad " & filename, 3
End Function
|