' struktura pro funce vyberu adresare
Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
' dekalrace fci z Windows pro vyhledani adresare
Private Declare Function SHBrowseForFolder Lib "shell32.dll" (ByRef bi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal dirName As String) As Long
Sub Main
PathName$=ActiveDocument.path ' defaultni cesta, tam co je design
'vytvoreni dialogu
Begin Dialog UserDialog 510,315,"Automat",.CallbackFunc ' %GRID:10,7,1,1
OKButton 40,287,100,21
CheckBox 20,14,90,14,"Ref",.CompRef
CheckBox 20,35,90,14,"Value",.CompValue
CheckBox 20,56,90,14,"Decal",.CompDecal
CheckBox 20,77,90,14,"Type",.CompType
CheckBox 20,98,90,14,"Side",.CompSide
CheckBox 20,119,90,14,"Height",.CompHeight
CheckBox 20,140,90,14,"Position",.CompPosition
GroupBox 150,7,150,70," Unit for position",.GroupBox1
OptionGroup .UnitSelect
OptionButton 170,28,90,14,"metric",.UnitMetric
OptionButton 170,49,90,14,"mils",.UnitMils
GroupBox 150,91,150,63,"Side",.GroupBox2
CheckBox 170,105,90,14,"TOP",.SideTop
CheckBox 170,126,90,14,"BOTT",.SideBott
CheckBox 350,105,130,14,"Skip zero height",.ZeroHeight
GroupBox 20,189,450,42,"Directory"
Text 40,210,310,14,PathName$,.Directory
PushButton 360,203,90,21,"browse ...",.browse
TextBox 30,252,440,21,.FileName
CancelButton 360,287,100,21
CheckBox 350,126,110,14,"To Excel",.ToExcel
GroupBox 330,7,140,70,"Type",.GroupBox3
CheckBox 350,28,90,14,"SMD",.TypeSMD
CheckBox 350,49,90,14,"KLASIC",.TypeKLASIC
CheckBox 20,161,100,14,"Orientation",.CompOrientation
End Dialog
Dim dlg As UserDialog
'defaultni nastaveni dialogu
dlg.FileName$="automat.txt"
dlg.CompRef=1
dlg.CompValue=1
dlg.CompDecal=1
dlg.CompType=1
dlg.CompSide=1
dlg.CompHeight=0
dlg.CompPosition=1
dlg.CompOrientation=1
dlg.UnitSelect=1
dlg.SideTop=1
dlg.SideBott=1
dlg.TypeKLASIC=1
dlg.TypeSMD=1
dlg.ToExcel=1
dlg.ZeroHeight=0
Dialog dlg
file = PathName & "\" & dlg.FileName
' otevri textovy soubor
On Error GoTo NotOpen
Open file For Output As #1
' hlavicka souburu
If dlg.CompRef=1 Then Print #1, "Ref"; Space(10-Len("Ref"));
If dlg.CompValue=1 Then Print #1, "Value"; Space(20-Len("Value"));
If dlg.CompDecal=1 Then Print #1, "Footprint"; Space(50-Len("Footprint"));
If dlg.CompType=1 Then Print #1, "Type" ; Space(10-Len("Type"));
If dlg.CompSide=1 Then Print #1, "Layer"; Space(10-Len("Layer"));
'If dlg.CompHeight=1 Then Print #1, "Height"; Space(10-Len("Height"));
If dlg.compPosition=1 Then
If dlg.UnitSelect=1 Then
Print #1, " X [mils]"; Space(30-Len(" X [mils]"));
Print #1, " Y [mils]"; Space(30-Len(" Y [mils]"));
End If
If dlg.UnitSelect=0 Then
Print #1, " X [mm]"; Space(30-Len(" X [mm]"));
Print #1, " Y [mm]"; Space(30-Len(" Y [mm]"));
End If
End If
If dlg.CompOrientation=1 Then Print #1, "Orientation [DEG]"; Space(20-Len("Orientation [DEG]"));
Print #1,"" 'odradkovani
' pro zvyseni rychlosti
LockServer
' vlastni vyplneni tabulky
For Each nextComp In ActiveDocument.Components
On Error Resume Next 'pokud neni Atribut Geometry.Height definovan,soucastku zapis do tabulky
If dlg.ZeroHeight =1 And ZeroItem(nextComp.Attributes("Geometry.Height").value)="TRUE" Then GoTo SkipItem ' preskoc polzky s nulovou vyskou
If dlg.SideTop=0 And ActiveDocument.LayerName(nextComp.layer)="Top" Then GoTo SkipItem 'preskoc soucastky na strane soucastek
If dlg.SideBott=0 And ActiveDocument.LayerName(nextComp.layer)="Bottom" Then GoTo SkipItem 'preskoc soucastky na strane spoju
If dlg.TypeSMD=0 And nextComp.IsSMD=True Then GoTo SkipItem
If dlg.TypeKLASIC=0 And nextComp.IsSMD=False Then GoTo SkipItem
If dlg.CompRef=1 Then Print #1, nextComp.Name; Space$(10-Len(nextComp.Name));
If dlg.CompValue=1 Then
On Error GoTo NotExist ' skoc, pokud atribut "value" neni definovan
Print #1, nextComp.Attributes("Value").value; Space$(20-Len(nextComp.Attributes("Value").value));
End If
If dlg.CompDecal=1 Then Print #1, nextComp.Decal; Space$(50-Len(nextComp.Decal));
If dlg.CompType=1 Then
If nextComp.IsSMD Then
Print #1,"SMD"; Space$(10-Len("SMD"));
End If
If Not nextComp.IsSMD Then
Print #1,"KLASIC"; Space(10-Len("KLASIC"));
End If
End If
If dlg.CompSide=1 Then Print #1, ActiveDocument.LayerName(nextComp.layer); Space$(10-Len(ActiveDocument.LayerName(nextComp.layer)));
If dlg.CompPosition=1 Then
If dlg.UnitSelect=1 Then 'jednotky jsou mils
Print #1, Str(Int(nextComp.PositionX(2))); Space$(30-Len(Str(Int(nextComp.PositionX))));
Print #1, Str(Int(nextComp.PositionY(2))); Space$(30-Len(Str(Int(nextComp.PositionY))));
End If
If dlg.UnitSelect=0 Then 'jednoky jsou mm
Print #1, Str((nextComp.PositionX(4))); Space$(30-Len(Str((nextComp.PositionX))));
Print #1, Str((nextComp.PositionY(4))); Space$(30-Len(Str((nextComp.PositionY))));
End If
End If
If dlg.CompOrientation=1 Then
Print #1, Str(Int(nextComp.Orientation)); Space$(30-Len(Str(Int(nextComp.Orientation))));
End If
Print #1,"" 'odradkovani
SkipItem:
Next nextComp
UnlockServer
' zavri textovy soubor
Close #1
If dlg.ToExcel=1 Then ToExcel(file) 'export do excelu
End
NotExist:
' atribut neni definovan, do tabulky zapis "NOTEXIST a jdi na dalsi polozku
Print #1, "NOTEXIST"; Space$(20-Len("NOTEXIST"));
Resume Next
NotOpen:
MsgBox "Not create files"
End Sub
' otevre v Excelu soubor se jmenem v file
Sub ToExcel(file)
' otevri excel a natahni soubor
On Error GoTo noExcel
Dim excelApp As Object
Set excelApp = CreateObject("Excel.Application")
On Error GoTo 0
excelApp.Visible = True
excelApp.Workbooks.OpenText FileName:= file
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:
' excel neni, otevri Notepad
Shell "Notepad " & file, 3
End Sub
'zjisti, zda dany string obsahuje nulove ciso
'pokud string obsahuje jen nuly a dalsi neciselne znaky, vraci "TRUE"
'pokud string obsahuje i jine cislice nebo jen neciselne znaky, vraci "FALSE"
Function ZeroItem$(Data$)
ZeroItem$="FALSE"
For i=1 To Len(Data$)
If Not(Mid(Data$,i,1)=" " Or Mid(Data$,i,1)=".") Then
If Mid(Data$,i,1)="0" Then
ZeroItem$="TRUE"
Else
If Mid(Data$,i,1)>"0" And Mid(Data$,i,1)<="9" Then
ZeroItem$="FALSE"
i=Len(Data$)
Else
i=Len(Data$)
End If
End If
End If
Next i
End Function
'obsluzna fce dialogu
Function CallbackFunc%(DlgItem$, Action%, SuppValue%)
Select Case Action%
Case 2 'stisknuto nejake tlacitko, nebo neco vybrano v boxech
If DlgItem$="browse" Then 'stisknuto tlacitko browse
s$=BrowseDirectory
If s<>"" Then
PathName=s
DlgText "Directory",PathName 'nahrad puvodni obsah okenka Path v dialogu
CallbackFunc=True ' refresuj dialog
End If
End If
If DlgItem$="Cancel" Then End 'zkonci script
End Select
End Function
' vrati vybranou cestu jako string
Function BrowseDirectory As String
Dim bi As BROWSEINFO, s As String*256, pos
bi.ulFlags = 9
bi.hwndOwner = dlgHandle
Dim pidl As Long
pidl = SHBrowseForFolder(bi)
If pidl <> 0 Then
If SHGetPathFromIDList(pidl, s) <> 0 Then
pos = InStr(s, Chr(0))
BrowseDirectory = Left(s, pos-1)
End If
End If
End Function
|