Orcad中调整Value和partreference位置的宏.doc

Sub AdjustPartsPropsLocation() MACROMENU AdLoc MACROKEY CTRL+P MACRODESCRIPTION Auto adjust Location of Parts display propertiesSelectObject -52.32, -20.83, FALSESelectObject -14.22, -1.02, FALSEConst MB_OKCANCEL = 1 Define buttons.Const vbOKOnly = 0Const IDCANCEL = 2Const MaxNumOfParts = 500Dim DgDef, Msg, Response, Title Declare variables.Title = 注意:Msg = 1. 该宏将自动调整原理图页面中元件的Part Refrence和Value的位置； & (Chr(13) & _2. 该宏将自动创建C:test.txt文件,如果该文件存在,其内容将被覆盖； & (Chr(13) & _3. 该程序正常情况下首先弹出一个对话框 begin,如果在该begin出现之前orcad弹出 & (Chr(13) & _ Select filter 请手动选择：parts（只选择parts,其他一概不要选）; & (Chr(13) & _4. 如果在begin对话框之后还出现select filter,请手动选择display properties; & (Chr(13) & _5. 该宏在orcad capture 10.3及winxp下测试通过,其他情况未测试 & (Chr(13) & _6. 请确保您使用的电阻电容形状和大小类似Capture库中的相应元件,并注意它们在库中的 & (Chr(13) & _ 原始图形是垂直放置的,即印脚在上下位置,而不是左右位置 & (Chr(13) & _7. 本程序假设R*,r*,L*,l*,C*,c*与Caputre的Discrete.olb中的R,C外形大致相似; & (Chr(13) & _ 其他字母开头的统一当作矩形行状的元件处理,其Part Refrence和Value置上。 & (Chr(13) & _8. 为防止出错死循环,本宏中设置了页面最大元件数为500; & (Chr(13) & _9. 请在Option-preference-select下设置选择方式为interselect,并确定； & (Chr(13) & _10.请在Option-schematic Page Properties-page size下选择inch， & (Chr(13) & _ 并确保您的原理图尺寸小于43X33 & (Chr(13) & _11.程序运行期间，请不要动键盘和鼠标，以免程序出错产生数据破坏； & (Chr(13) & _12.请确保您在运行该程序之前做好了备份,如有数据丢失或损坏,概不负责 & (Chr(13)Msg = Msg & (Chr(13) & 您确认要继续吗?DgDef = MB_OKCANCEL Describe dialog.Response = MsgBox(Msg, DgDef, Title) Get user response.If Response = IDCANCEL Then MsgBox 退出程序！ Exit SubElse action.End IfDim ExitLoop As Integer ExitLoop = 0Dim partName As StringDim TxtFileName As String TxtFileName = c:test.txtDim PartLocX As StringDim PartLocY As StringDim ReturnValue As Integersometimes the following is ok,sometimes is unvalid :(SendKeys %vfaTAB 2 enter, True popup a select filter dialo and set parts filterMsg = 如果您刚才看到了select filter对话框,而您没有只选择Parts, & (Chr(13) & _建议您立刻退出,否则可以继续！Response = MsgBox(Msg, DgDef, 您要继续吗？) Get user response.If Response = IDCANCEL Then MsgBox (退出程序！) Exit SubElse action.End IfSendKeys %vfaUP 12 enter,True popup a select filter dialo and set parts filterunselectallGoToAbsolute 0#, 0#SelectBlock 0#, 0#, 43#, 33#, FalseRemoveDisplayProperty Part ReferenceRemoveDisplayProperty ValueOpen Property Editor and then Select,copy to clipboard and close Property EditorShowSpreadsheetSendKeys LEFT+DOWNc%-DOWN 5ENTERcreat a empty text: c:test.txtOpen TxtFileName For Output As #1CloseReturnValue = Shell(notepad.EXE c:test.txt, 1) Run NotepadAppActivate test.txt - 记事本SendKeys av%fs%fx, True Paste from clipboard and save on the disk c:.ExitLoop = 0Dim FileData As StringDim PartRotation As StringDim PartRef As StringDim displayPro As StringDim K As IntegerdisplayPro = Dim aa As StringDim nTabNameBegin As IntegerDim nTabNum As IntegerDim nPreTab As IntegerDim nEndTab As Integer nTabNum = 0Dim TmpCnt As Integerpopup a select filter dialog and set display property filterSelectAllunselectallMsg = 1:请使用鼠标点击确定按钮，不要直接使 & (Chr(13) & _ 用ENTER，因为此时焦点可能不再该窗口上 & (Chr(13) & (Chr(13) & _2:确定后开始调整Part ref和value的位置，这 & (Chr(13) & _ 可能要花费较长的时间，请耐心等候.Response = MsgBox(Msg, 48, 警告)MsgBox(开始调整Part ref和value的位置，这可能要花费较长的时间，请耐心等候)SendKeys %vfaTAB 8,TrueSendKeys %vfaUP 8 ENTER, True unselectallOpen TxtFileName For Input As #1Get File header informationIf (Not EOF(1) Then Line Input #1, FileData FileData = LCase(FileData) MsgBox(FileData) If (Not (Len(FileData) 0) Then MsgBox (1:文件格式错误或文件不存在) Exit Sub End If nTabNameBegin = InStr(1, FileData, Chr$(9) & name & Chr$(9), 1) If nTabNameBegin = 0 Then MsgBox (2:文件格式错误或文件不存在) Exit Sub End If FileData = Left(FileData, nTabNameBegin - 1) TmpCnt = InStr(1, FileData, Chr$(9), 1) Do While (TmpCnt 0 And TmpCnt Len(FileData) nTabNum = nTabNum + 1 TmpCnt = InStr(TmpCnt + 1, FileData, Chr$(9), 1) LoopEnd IfDo While Not EOF(1) TmpCnt = 1 K = nTabNum + 1 Line Input #1, FileData Do While (K) nPreTab = InStr(TmpCnt, FileData, Chr$(9), 1) TmpCnt = nPreTab + 1 MsgBox(Str$(NTabNum)&: & Str$(nPreTab) K = K - 1 Loop nEndTab = InStr(TmpCnt, FileData, Chr$(9), 1) partName = Mid(FileData, nPreTab + 1, Abs(nEndTab - nPreTab - 1) MsgBox(Str$(nPreTab)&: & Str$(nEndTab) & : & partName ) Findparts partName, False GetProperty Rotation, PartRotation GetProperty Part Reference, PartRef The following for Resistor If (Left$(PartRef, 1) = R) Or (Left$(PartRef, 1) = r) Or (Left$(PartRef, 1) = L) Or (Left$(PartRef, 1) = l) Then DisplayProperty Value, Arial, 9, False, False, 48, 0 SelectBlock 0#, 0#, 0.1, 0.1, False GetProperty Rotation , PartRotation If (Left$(PartRotation, 3) = 0 Or Left$(PartRotation, 3) = 180) Then Drag 0.12, 0.3, False Else Drag 0.3, 0#, False End If Setfont Arial, 1, False, False Findparts partName, False DisplayProperty Part Reference, Arial, 9, False, False, 48, 0 SelectBlock 0#, 0#, 0.1, 0.1, False GetProperty Rotation , PartRotation If (Left$(PartRotation, 3) = 0 Or Left$(PartRotation, 3) = 180) Then Drag 0.12, -0.1, False Else Drag -0.1, 0#, False End If Setfont Arial, 1, False, False The following for Capacity ElseIf (Left$(PartRef, 1) = C) Or (Left$(PartRef, 1) = c) Then DisplayProperty Value, Arial, 9, False, False, 48, 0 SelectBlock 0#, 0#, 0.1, 0.1, False GetProperty Rotation , PartRotation If (Left$(PartRotation, 3) = 0 Or Left$(PartRotation, 3) = 180) Then Drag 0.12, 0.1, False Else Drag 0.12, 0#, False End If Setfont Arial, 1, False, False Findparts partName, False DisplayProperty Part Reference, Arial, 9, False, False, 48, 0 SelectBlock 0#, 0#, 0.1, 0.1, False GetProperty Rotation , PartRotation If (Left$(PartRotation, 3) = 0 Or Left$(PartRotation, 3) = 180) Then Drag 0.12, -0.1, False Else Drag -0.2, 0#, False End If Setfont Arial, 1, False, False The following for ot