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

library

?curdirlinks? -

Blame information for rev 3

Line No. Rev Author Line
1 3 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 ' nety lze tridit podle jmena, delky, nebo poctu prokovu
4  
5 Option Explicit
6  
7 ' definice konstant potrebnych pro zmenu fontu
8 Const LOGPIXELSY = 90
9 Const WM_SETFONT = &H30
10  
11 ' deklarace funkci potrebnych pro zmenu fontu
12 Declare Function CreateFontA Lib "gdi32" ( _
13 ByVal nHeight As Long, _
14 ByVal nWidth As Long, _
15 ByVal nEscapement As Long, _
16 ByVal nOrientation As Long, _
17 ByVal fnWeight As Long, _
18 ByVal fdwItalic As Long, _
19 ByVal fdwUnderline As Long, _
20 ByVal fdwStrikeOut As Long, _
21 ByVal fdwCharSet As Long, _
22 ByVal fdwOutputPrecision As Long, _
23 ByVal fdwClipPrecision As Long, _
24 ByVal fdwQuality As Long, _
25 ByVal fdwPitchAndFamily As Long, _
26 ByVal lpszFace As String _
27 ) As Long
28  
29 Declare Function DeleteObject Lib "gdi32" ( _
30 ByVal hObject As Long _
31 ) As Long
32  
33 Declare Function GetDeviceCaps Lib "gdi32" ( _
34 ByVal hDC As Long, _
35 ByVal nIndex As Long _
36 ) As Long
37  
38 Declare Function GetDlgItem Lib "user32" ( _
39 ByVal hDlg As Long, _
40 ByVal nIDDlgItem As Long _
41 ) As Long
42  
43 Declare Function GetWindowDC Lib "user32" ( _
44 ByVal hWnd As Long _
45 ) As Long
46  
47 Declare Function ReleaseDC Lib "user32" ( _
48 ByVal hWnd As Long, _
49 ByVal hDC As Long _
50 ) As Long
51  
52 Declare Function SendMessageA Lib "user32" ( _
53 ByVal hWnd As Long, _
54 ByVal uMsg As Long, _
55 ByVal wParam As Long, _
56 ByVal lParam As Long _
57 ) As Long
58  
59 'deklarace promennych
60 Dim hFont As Long ' pro zmenu fontu
61 Dim SelNet As Boolean ' true = budeme vybirat nety v designu
62 Dim Sort As String ' urcuje, podle ceho se bude tridit
63  
64  
65 Sub Main
66 'alokace pole pro vlastnosti netu (dynamicke pole)
67 ReDim ListNetsName$(ActiveDocument.Nets.Count) ' pole pro jmeno netu
68 ReDim ListNetsLength(ActiveDocument.Nets.Count) ' pole pro delku netu
69 ReDim ListNetsVias(ActiveDocument.Nets.Count) ' pole pro pocet via na netu
70 ReDim ListNets$(ActiveDocument.Nets.Count) ' stringove pole vsech vlastnosti dohromady v poradi jmeno, delka, pocet via
71  
72 Debug. Print"nacitame data z databaze"
73 FillArray
74 Debug.Print"tridime"
75 SortByName(True)
76 Debug.Print"skladame do stringoveho pole"
77 InfosToStringArray
78  
79 Debug.Print"zobrazujeme dialog"
80  
81 'zmena fontu na Courier (fixfont)
82 Dim hDC As Long
83 hDC = GetWindowDC(0)
84 Dim Height As Long
85 Height = 36*GetDeviceCaps(hDC,LOGPIXELSY)/250
86 ReleaseDC 0,hDC
87 hFont = CreateFontA(Height,0,0,0,0,0,0,0,0,0,0,0,0,"Courier")
88  
89 Begin Dialog UserDialog 500,210,"Length And vias",.CallbackFunc ' %GRID:10,7,1,1
90 CheckBox 180,147,100,14,"Select net",.Check
91 CancelButton 170,182,110,21
92 ListBox 20,21,450,112,ListNets(),.ListBox
93  
94 Text 20,7,90,14,"Name:",.Text1
95 Text 170,7,90,14,"Length:",.Text2
96 Text 300,7,90,14,"Vias:",.Text3
97  
98 PushButton 30,182,110,21,"To Excel",.PushButton1
99 PushButton 30,147,110,21,"Refresh",.Refresh
100 OptionGroup .Sort
101 OptionButton 330,147,120,14,"Sort by Name",.SortName
102 OptionButton 330,168,120,14,"Sort by Length",.SortLength
103 OptionButton 330,189,120,14,"Sort by Vias",.SortVias
104  
105 End Dialog
106  
107 Dim dlg As UserDialog
108  
109 SelNet=True
110 dlg.Check=1 'prepinac nastav na select
111 Sort="Name"
112 Dialog dlg
113  
114 ' po ukonceni programu smaz zmeneny font
115 DeleteObject hFont
116 End Sub
117  
118 Sub FillArray
119 'nacteni informaci o netech do info poli pole
120 Dim i As Integer
121 i = 0
122 Dim NextNet As Object
123 For Each NextNet In ActiveDocument.Nets
124 ListNetsName(i)=NextNet.Name
125 ListNetsLength(i)=NextNet.Length(True)
126 ListNetsVias(i)=NextNet.Vias.Count
127 i=i+1
128 Next NextNet
129 End Sub
130  
131 Sub InfosToStringArray
132 ' slozi informacni pole do jednoho stringoveho pole
133 Dim i As Integer
134 For i=0 To ActiveDocument.Nets.Count-1
135 ListNets$(i)=AddSpace(ListNetsName(i))+AddSpace(Str(Int(ListNetsLength(i))))+ListNetsVias(i)
136 Next
137 End Sub
138 Sub SortByName(UpSort As Boolean)
139 'setridi informacni pole podle pole jmena
140 'je-li UpSort=1 tridime vzestupne, je-li 0 tak sestupne
141 Dim N As Integer
142 Dim Gap As Integer
143 Dim i As Integer
144 Dim j As Integer
145 Dim temp As Variant
146 Dim count As Long
147  
148 count=0
149 N=ActiveDocument.Nets.Count ' pocet netu v informacnich polich
150 Debug.Print"N";n
151 Gap=N\2
152 While gap>0
153 i=gap
154 While (i<N)
155 j=i-Gap
156 While j>=0
157 If (StrComp(ListNetsName(j),ListNetsName(j+gap))=-1 Xor UpSort) Then
158 temp=ListNetsLength(j)
159 ListNetsLength(j)=ListNetsLength(j+gap)
160 ListNetsLength(j+gap)=temp
161 ' je treba prehazet i pole se jmenem a poctem via
162 count=count+1
163 temp=ListNetsName(j)
164 ListNetsName(j)=ListNetsName(j+gap)
165 ListNetsName(j+gap)=temp
166 temp=ListNetsVias(j)
167 ListNetsVias(j)=ListNetsVias(j+gap)
168 ListNetsVias(j+gap)=temp
169 End If
170 j=j-gap
171 Wend
172 i=i+1
173 Wend
174 Gap=Gap\2
175 Wend
176  
177 Debug.Print"count";count
178 End Sub
179 Sub SortByLength(UpSort As Boolean)
180 'setridi informacni pole podle pole delky
181 'je-li UpSort=1 tridime vzestupne, je-li 0 tak sestupne
182 Dim N As Integer
183 Dim Gap As Integer
184 Dim i As Integer
185 Dim j As Integer
186 Dim temp As Variant
187 Dim count As Long
188  
189 count=0
190 N=ActiveDocument.Nets.Count ' pocet netu v informacnich polich
191 Debug.Print"N";n
192 Gap=N\2
193 While gap>0
194 i=gap
195 While (i<N)
196 j=i-Gap
197 While j>=0
198 If ((ListNetsLength(j)<ListNetsLength(j+gap)) Xor UpSort) Then
199 temp=ListNetsLength(j)
200 ListNetsLength(j)=ListNetsLength(j+gap)
201 ListNetsLength(j+gap)=temp
202 ' je treba prehazet i pole se jmenem a poctem via
203 count=count+1
204 temp=ListNetsName(j)
205 ListNetsName(j)=ListNetsName(j+gap)
206 ListNetsName(j+gap)=temp
207 temp=ListNetsVias(j)
208 ListNetsVias(j)=ListNetsVias(j+gap)
209 ListNetsVias(j+gap)=temp
210 End If
211 j=j-gap
212 Wend
213 i=i+1
214 Wend
215 Gap=Gap\2
216 Wend
217  
218 Debug.Print"count";count
219 End Sub
220  
221  
222  
223 Sub SortByVia(UpSort As Boolean)
224 'setridi informacni pole podle pole delky
225 'je-li UpSort=1 tridime vzestupne, je-li 0 tak sestupne
226 Dim N As Integer
227 Dim Gap As Integer
228 Dim i As Integer
229 Dim j As Integer
230 Dim temp As Variant
231  
232 N=ActiveDocument.Nets.Count ' pocet netu v informacnich polich
233 Gap=N\2
234 While gap>0
235 i=gap
236 While (i<N)
237 j=i-Gap
238 While j>=0
239 If ((ListNetsVias(j)<ListNetsVias(j+gap)) Xor UpSort) Then
240 temp=ListNetsLength(j)
241 ListNetsLength(j)=ListNetsLength(j+gap)
242 ListNetsLength(j+gap)=temp
243 temp=ListNetsName(j)
244 ListNetsName(j)=ListNetsName(j+gap)
245 ListNetsName(j+gap)=temp
246 temp=ListNetsVias(j)
247 ListNetsVias(j)=ListNetsVias(j+gap)
248 ListNetsVias(j+gap)=temp
249 End If
250 j=j-gap
251 Wend
252 i=i+1
253 Wend
254 Gap=Gap\2
255 Wend
256 End Sub
257  
258 'doplni string mezerami na 15 znaku
259 Function AddSpace$(data$)
260 Dim NumSpace As Integer
261 NumSpace=15 - Len(data$)
262 AddSpace=data+Space$(NumSpace)
263 End Function
264 'vyjme z prvnich 15 znaku stringu pocatecni zaznam
265 Function SepareNameNet$(data$)
266 Dim Pom2 As String
267 Dim i As Integer
268 SepareNameNet$=""
269 Pom2$=Left(data$,15)
270 For i=1 To 15
271 If Mid$(Pom2$,i,1)<>" " Then
272 SepareNameNet$=SepareNameNet$+Mid$(Pom2$,i,1)
273 End If
274 Next i
275 End Function
276 ' vlastni funkce dialogu
277 Function CallbackFunc%(DlgItem$, Action%, SuppValue%)
278 Dim Pom As Variant
279 Select Case Action%
280  
281 Case 1 ' zde probiha inicializace dialog boxu
282 ' menime font v listboxu
283 Dim hWnd As Long
284 hWnd = GetDlgItem(SuppValue,DlgControlId("ListBox"))
285 SendMessageA hWnd,WM_SETFONT,hFont,1
286  
287 Case 2 'stisknuto nejake tlacitko, nebo neco vybrano v boxech
288 If DlgItem$="ListBox" Then ' vybrali jsme radku v boxu ListBox
289 If SelNet Then
290 ' deselectuj vsechny objekty
291 ActiveDocument.SelectObjects(ppcbObjectTypeAll,"",False)
292 'selectuj vybrany net
293 ActiveDocument.SelectObjects(ppcbObjectTypeNet,SepareNameNet$(ListNetsName$(SuppValue%)),True)
294 End If
295 End If
296  
297 ' vybirame, zda se budou draty vybirat, ci nikoli
298 If DlgItem$="Check" Then
299 If SuppValue%=1 Then SelNet=True
300 If SuppValue%=0 Then SelNet=False
301 End If
302  
303 ' vybirame, jak se budou informace v listboxu tridit
304 If DlgItem$="Sort" Then
305 Debug.Print"sort value:";SuppValue
306 If SuppValue%=0 Then
307 SortByName(True)
308 InfosToStringArray
309 Sort="Name"
310 DlgListBoxArray "ListBox",ListNets()
311 End If
312 If SuppValue%=1 Then
313 SortByLength(False)
314 InfosToStringArray
315 Sort="Length"
316 DlgListBoxArray "ListBox",ListNets()
317 End If
318 If SuppValue%=2 Then
319 SortByVia(False)
320 InfosToStringArray
321 Sort="Via"
322 DlgListBoxArray "ListBox",ListNets()
323 End If
324 End If
325  
326 ' export do excelu
327 If DlgItem$="PushButton1" Then pom=InfoToExcel
328 If DlgItem$="Cancel" Then End
329  
330 ' refresh udaju v listboxu
331 If DlgItem$="Refresh" Then
332 CallBackFunc%=True
333 FillArray
334 If Sort="Name" Then SortByName(True)
335 If Sort="Length" Then SortByLength(False)
336 If Sort="Via" Then SortByVia(False)
337 InfosToStringArray
338 DlgListBoxArray "ListBox",ListNets()
339 End If
340  
341 Case 4
342 Debug.Print"focus"
343  
344 End Select
345 End Function
346  
347 Function InfoToExcel
348 Dim FileName As Variant
349 Dim i As Integer
350 ' Open temporarly text file
351 Randomize
352 filename = DefaultFilePath & "\tmp" & CInt(Rnd()*10000) & ".txt"
353 Open filename For Output As #1
354  
355 ' Output Headers
356 Print #1, "NetName"; Space(50);
357 Print #1, "NetLength"; Space(50);
358 Print #1, "Vias"; Space(0)
359  
360  
361 ' Lock server to speed up process
362 LockServer
363  
364 ' Go through each component in the design and output values
365 For i=0 To ActiveDocument.Nets.Count
366 Print #1, ActiveDocument.Nets.Name; Space$(50-Len(ActiveDocument.Nets.Name));
367 Print #1, Str(Int(ActiveDocument.Nets.Length(True))); Space$(50-Len((Str(Int(ActiveDocument.Nets.Length)))));
368 Print #1, ActiveDocument.Nets.Vias.Count; Space$(50-Len(ActiveDocument.Nets.Vias.Count))
369 Next i
370  
371 ' Unlock the server
372 UnlockServer
373  
374 ' Close the text file
375 Close #1
376  
377 ' Start Excel and loads the text file
378 On Error GoTo noExcel
379 Dim excelApp As Object
380 Set excelApp = CreateObject("Excel.Application")
381 On Error GoTo 0
382 excelApp.Visible = True
383 excelApp.Workbooks.OpenText FileName:= filename
384 excelApp.Rows("1:1").Select
385 With excelApp.Selection
386 .Font.Bold = True
387 .Font.Italic = True
388 End With
389 excelApp.Range("A1").Select
390 Set excelApp = Nothing
391 End
392  
393 noExcel:
394 ' Display the text file
395 Shell "Notepad " & filename, 3
396  
397  
398 End Function
{BLAME END}
{FOOTER START}

Powered by WebSVN v2.8.3