?lang_form? ?lang_select? ?lang_submit? ?lang_endform?
{HEADER END}
{BLAME START}

library

?curdirlinks? -

Blame information for rev 21

Line No. Rev Author Line
1 21 kaklik ' makro zjistujici delku jednolivych netu a pocet prokovu na netu v celem designu,
2 ' lze vyexportovat do excelu a vybrat prislusny net v designu
3  
4 Option Explicit
5  
6 ' definice konstant potrebnych pro zmenu fontu
7 Const LOGPIXELSY = 90
8 Const WM_SETFONT = &H30
9  
10 ' deklarace funkci potrebnych pro zmenu fontu
11 Declare Function CreateFontA Lib "gdi32" ( _
12 ByVal nHeight As Long, _
13 ByVal nWidth As Long, _
14 ByVal nEscapement As Long, _
15 ByVal nOrientation As Long, _
16 ByVal fnWeight As Long, _
17 ByVal fdwItalic As Long, _
18 ByVal fdwUnderline As Long, _
19 ByVal fdwStrikeOut As Long, _
20 ByVal fdwCharSet As Long, _
21 ByVal fdwOutputPrecision As Long, _
22 ByVal fdwClipPrecision As Long, _
23 ByVal fdwQuality As Long, _
24 ByVal fdwPitchAndFamily As Long, _
25 ByVal lpszFace As String _
26 ) As Long
27  
28 Declare Function DeleteObject Lib "gdi32" ( _
29 ByVal hObject As Long _
30 ) As Long
31  
32 Declare Function GetDeviceCaps Lib "gdi32" ( _
33 ByVal hDC As Long, _
34 ByVal nIndex As Long _
35 ) As Long
36  
37 Declare Function GetDlgItem Lib "user32" ( _
38 ByVal hDlg As Long, _
39 ByVal nIDDlgItem As Long _
40 ) As Long
41  
42 Declare Function GetWindowDC Lib "user32" ( _
43 ByVal hWnd As Long _
44 ) As Long
45  
46 Declare Function ReleaseDC Lib "user32" ( _
47 ByVal hWnd As Long, _
48 ByVal hDC As Long _
49 ) As Long
50  
51 Declare Function SendMessageA Lib "user32" ( _
52 ByVal hWnd As Long, _
53 ByVal uMsg As Long, _
54 ByVal wParam As Long, _
55 ByVal lParam As Long _
56 ) As Long
57  
58 'deklarace promennych
59 Dim hFont As Long ' pro zmenu fontu
60 Dim SelNet As Boolean ' true = budeme vybirat nety v designu
61 Dim Sort As String ' urcuje, podle ceho se bude tridit
62  
63  
64 Sub Main
65 'alokace pole pro vlastnosti netu (dynamicke pole)
66 ReDim ListNetsName$(ActiveDocument.Nets.Count) ' pole pro jmeno netu
67 ReDim ListNetsLength(ActiveDocument.Nets.Count) ' pole pro delku netu
68 ReDim ListNetsVias(ActiveDocument.Nets.Count) ' pole pro pocet via na netu
69 ReDim ListNets$(ActiveDocument.Nets.Count) ' stringove pole vsech vlastnosti dohromady v poradi jmeno, delka, pocet via
70  
71 FillArray
72 InfosToStringArray
73  
74 'zmena fontu na Courier (fixfont)
75 Dim hDC As Long
76 hDC = GetWindowDC(0)
77 Dim Height As Long
78 Height = 36*GetDeviceCaps(hDC,LOGPIXELSY)/250
79 ReleaseDC 0,hDC
80 hFont = CreateFontA(Height,0,0,0,0,0,0,0,0,0,0,0,0,"Courier")
81  
82 Begin Dialog UserDialog 500,210,"Length And vias",.CallbackFunc ' %GRID:10,7,1,1
83 CheckBox 350,147,100,14,"Select net",.Check
84 CancelButton 30,154,110,21
85 ListBox 20,21,450,112,ListNets(),.ListBox
86  
87 Text 20,7,90,14,"Name:",.Text1
88 Text 170,7,90,14,"Length:",.Text2
89 Text 300,7,90,14,"Vias:",.Text3
90  
91 PushButton 30,182,110,21,"To Excel",.PushButton1
92 PushButton 190,182,110,21,"Refresh",.Refresh
93  
94 End Dialog
95  
96 Dim dlg As UserDialog
97  
98 SelNet=True
99 dlg.Check=1 'prepinac nastav na select
100 Dialog dlg
101  
102 ' po ukonceni programu smaz zmeneny font
103 DeleteObject hFont
104 End Sub
105  
106 Sub FillArray
107 'nacteni informaci o netech do info poli
108 Dim i As Integer
109 i = 0
110 Dim NextNet As Object
111 For Each NextNet In ActiveDocument.Nets
112 ListNetsName(i)=NextNet.Name
113 ListNetsLength(i)=NextNet.Length(True)
114 ListNetsVias(i)=NextNet.Vias.Count
115 i=i+1
116 Next NextNet
117 End Sub
118  
119 Sub InfosToStringArray
120 ' slozi informacni pole do jednoho stringoveho pole
121 Dim i As Integer
122 For i=0 To ActiveDocument.Nets.Count-1
123 ListNets$(i)=AddSpace(ListNetsName(i))+AddSpace(Str(Int(ListNetsLength(i))))+ListNetsVias(i)
124 Next
125 End Sub
126 'doplni string mezerami na 15 znaku
127 Function AddSpace$(data$)
128 Dim NumSpace As Integer
129 NumSpace=15 - Len(data$)
130 AddSpace=data+Space$(NumSpace)
131 End Function
132 'vyjme z prvnich 15 znaku stringu pocatecni zaznam
133 Function SepareNameNet$(data$)
134 Dim Pom2 As String
135 Dim i As Integer
136 SepareNameNet$=""
137 Pom2$=Left(data$,15)
138 For i=1 To 15
139 If Mid$(Pom2$,i,1)<>" " Then
140 SepareNameNet$=SepareNameNet$+Mid$(Pom2$,i,1)
141 End If
142 Next i
143 End Function
144 ' vlastni funkce dialogu
145 Function CallbackFunc%(DlgItem$, Action%, SuppValue%)
146 Dim Pom As Variant
147 Select Case Action%
148  
149 Case 1 ' zde probiha inicializace dialog boxu
150 ' menime font v listboxu
151 Dim hWnd As Long
152 hWnd = GetDlgItem(SuppValue,DlgControlId("ListBox"))
153 SendMessageA hWnd,WM_SETFONT,hFont,1
154  
155 Case 2 'stisknuto nejake tlacitko, nebo neco vybrano v boxech
156 If DlgItem$="ListBox" Then ' vybrali jsme radku v boxu ListBox
157 If SelNet Then
158 ' deselectuj vsechny objekty
159 ActiveDocument.SelectObjects(ppcbObjectTypeAll,"",False)
160 'selectuj vybrany net
161 ActiveDocument.SelectObjects(ppcbObjectTypeNet,SepareNameNet$(ListNetsName$(SuppValue%)),True)
162 End If
163 End If
164  
165 ' vybirame, zda se budou draty vybirat, ci nikoli
166 If DlgItem$="Check" Then
167 If SuppValue%=1 Then SelNet=True
168 If SuppValue%=0 Then SelNet=False
169 End If
170  
171  
172 ' export do excelu
173 If DlgItem$="PushButton1" Then pom=InfoToExcel
174 If DlgItem$="Cancel" Then End
175  
176 ' refresh udaju v listboxu
177 If DlgItem$="Refresh" Then
178 CallBackFunc%=True
179 FillArray
180 InfosToStringArray
181 DlgListBoxArray "ListBox",ListNets()
182 End If
183  
184 Case 4
185 Debug.Print"focus"
186  
187 End Select
188 End Function
189  
190 Function InfoToExcel
191 Dim FileName As Variant
192 Dim i As Integer
193 ' Open temporarly text file
194 Randomize
195 filename = DefaultFilePath & "\tmp" & CInt(Rnd()*10000) & ".txt"
196 Open filename For Output As #1
197  
198 ' Output Headers
199 Print #1, "NetName"; Space(50);
200 Print #1, "NetLength"; Space(50);
201 Print #1, "Vias"; Space(0)
202  
203  
204 ' Lock server to speed up process
205 LockServer
206  
207 ' Go through each component in the design and output values
208 For i=0 To ActiveDocument.Nets.Count
209 Print #1, ActiveDocument.Nets.Name; Space$(50-Len(ActiveDocument.Nets.Name));
210 Print #1, Str(Int(ActiveDocument.Nets.Length(True))); Space$(50-Len((Str(Int(ActiveDocument.Nets.Length)))));
211 Print #1, ActiveDocument.Nets.Vias.Count; Space$(50-Len(ActiveDocument.Nets.Vias.Count))
212 Next i
213  
214 ' Unlock the server
215 UnlockServer
216  
217 ' Close the text file
218 Close #1
219  
220 ' Start Excel and loads the text file
221 On Error GoTo noExcel
222 Dim excelApp As Object
223 Set excelApp = CreateObject("Excel.Application")
224 On Error GoTo 0
225 excelApp.Visible = True
226 excelApp.Workbooks.OpenText FileName:= filename
227 excelApp.Rows("1:1").Select
228 With excelApp.Selection
229 .Font.Bold = True
230 .Font.Italic = True
231 End With
232 excelApp.Range("A1").Select
233 Set excelApp = Nothing
234 End
235  
236 noExcel:
237 ' Display the text file
238 Shell "Notepad " & filename, 3
239  
240  
241 End Function
{BLAME END}
{FOOTER START}

Powered by WebSVN v2.8.3