AutoCAD文字处理VB编程.docx

AutoCAD文字处理VB编程.docx

《AutoCAD文字处理VB编程.docx》由会员分享，可在线阅读，更多相关《AutoCAD文字处理VB编程.docx（26页珍藏版）》请在冰点文库上搜索。

AutoCAD文字处理VB编程

OptionExplicit

DimoExcelAsObject

PrivateDeclareFunctionlstrlenLib"kernel32"Alias"lstrlenA"（ByVallpStringAsString）AsLong

DimoBookAsObject

DimoSheetAsObject

DimoAutoCADAsObject

DimoModelSpaceAsObject

DimoSelSetAsObject

DimoMTextAsObject

DimoTextAsObject

DimoTextStylesAsObject

'ÒÔÏ¿ÉÁгö¼¸ºõËùÓкº×Ö

'ForI=19968To40869

'Cells（I-19967,1）=ChrW（I）

'Next

PrivateFunctionBeingChinese（ByValCharacterAsString）AsBoolean'ºº×Ö

BeingChinese=False

DimIAsInteger

ForI=1ToLen（Character）

IfAsc（Mid（Character,I,1））<0Then

BeingChinese=True

ExitFor

EndIf

NextI

EndFunction

PrivateFunctionBeingDoubleByte（ByValCharacterAsString）AsBoolean'Ë«×Ö½Ú

Iflstrlen（Character）-Len（Character）>0Then

BeingDoubleByte=True

Else

BeingDoubleByte=False

EndIf

EndFunction

PrivateFunctionFullNameOfFile（ByValPathOfFileAsString,ByValNameOfFileAsString）AsString

FullNameOfFile=IIf（Right（PathOfFile,1）="\",PathOfFile&NameOfFile,PathOfFile&"\"&NameOfFile）

EndFunction

PrivateSubBindAutoCAD（）

IfNotoAutoCADIsNothingThenExitSub

OnErrorResumeNext

SetoAutoCAD=GetObject（,"Autocad.Application"）

IfErr.Number<>0Then'ûÓдò¿ª

Err.Clear

SetoAutoCAD=CreateObject（"Autocad.application"）

IfErr.Number<>0Then

Err.Clear

ExitSub

EndIf

oAutoCAD.Visible=True

EndIf

'²»ÂÛSingleDocumentModeµÄÖµ（Âß¼Öµ）£¬Ö±½Ó´ò¿ªÄ£°å

IfoAutoCAD.documents.Count=0ThenoAutoCAD.documents.AddFullNameOfFile（App.Path,"wcad.dwt"）

IfErr.Number<>0ThenErr.Clear

OnErrorGoTo0

EndSub

PrivateSubBindExcel（）

IfNotoExcelIsNothingThenExitSub

OnErrorResumeNext

SetoExcel=GetObject（,"Excel.Application"）

IfErr.Number<>0Then'ûÓдò¿ª

Err.Clear

SetoExcel=CreateObject（"Excel.application"）

IfErr.Number<>0Then

Err.Clear

ExitSub

EndIf

oExcel.Visible=True

EndIf

OnErrorGoTo0

EndSub

PrivateSubUnBindExcel（）

OnErrorResumeNext

SetoExcel=Nothing

SetoBook=Nothing

SetoSheet=Nothing

OnErrorGoTo0

EndSub

PrivateSubUnBindAutoCAD（）

OnErrorResumeNext

SetoAutoCAD=Nothing

SetoModelSpace=Nothing

SetoSelSet=Nothing

SetoMText=Nothing

SetoText=Nothing

SetoTextStyles=Nothing

OnErrorGoTo0

EndSub

PrivateSubGetAllText（）

OnErrorGoToERR_GETALLTEXT

BindAutoCAD

BindExcel

'Changethemousepointertoanhourglass.

Screen.MousePointer=11

DimI,J,IRowAsInteger

DimDuplicateAsBoolean

IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen

SetoModelSpace=oAutoCAD.ActiveDocument.ModelSpace

SetoBook=oExcel.Workbooks.Add

IfErr.Number<>0Then

Err.Clear

ExitSub

EndIf

IfoBookIsNothingThenExitSub

SetoSheet=oBook.Sheets

（1）'µÚ1Ò³Ö½

IfoSheetIsNothingThenExitSub

IRow=0

ForI=0TooModelSpace.Count-1

WithoModelSpace.Item（I）

DoEvents

If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then

lblTip=.textString

IfBeingChinese（.textString）Then'Óкº×Ö

Duplicate=False

ForJ=1ToIRow

If.textString=oSheet.Cells（J,1）Then

Duplicate=True

ExitFor

EndIf

NextJ

IfNotDuplicateThen'±ÜÃâÖظ´

IRow=IRow+1

oSheet.Cells（IRow,1）=.textString'\PÊÇÐмäÓ²»Ø³µ

EndIf

EndIf

EndIf

EndWith

NextI

EndIf

OnErrorGoTo0

'Resetthemousepointer.

Screen.MousePointer=0

lblTip="¹²µ¼³ö"+Str（IRow）+"´¦ÎÄ×Ö¡£"

UnBindExcel

UnBindAutoCAD

ExitSub

ERR_GETALLTEXT:

'Resetthemousepointer.

Screen.MousePointer=0

UnBindExcel

UnBindAutoCAD

lblTip=Err.Number&"Error:

"&Err.Description

EndSub

PrivateSubGetPartText（）

OnErrorGoToERR_GETPARTTEXT

BindAutoCAD

BindExcel

'Changethemousepointertoanhourglass.

Screen.MousePointer=11

DimI,J,IRowAsInteger

DimDuplicateAsBoolean

DimSelPartAsString

IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen

Randomize

SelPart="S"&CStr（Int（10000*Rnd）+1）

SetoSelSet=oAutoCAD.ActiveDocument.SelectionSets.Add（SelPart）

AppActivateoAutoCAD.Caption

oSelSet.SelectOnScreen

SetoBook=oExcel.Workbooks.Add

IfErr.Number<>0Then

Err.Clear

ExitSub

EndIf

IfoBookIsNothingThenExitSub

SetoSheet=oBook.Sheets

（1）'µÚ1Ò³Ö½

IfoSheetIsNothingThenExitSub

IRow=0

ForI=0TooSelSet.Count-1

WithoSelSet.Item（I）

DoEvents

If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then

lblTip=.textString

IfBeingChinese（.textString）Then'Óкº×Ö

Duplicate=False

ForJ=1ToIRow

If.textString=oSheet.Cells（J,1）Then

Duplicate=True

ExitFor

EndIf

NextJ

IfNotDuplicateThen'±ÜÃâÖظ´

IRow=IRow+1

oSheet.Cells（IRow,1）=.textString'\PÊÇÐмäÓ²»Ø³µ

EndIf

EndIf

EndIf

EndWith

NextI

AppActivateoExcel.Caption

EndIf

OnErrorGoTo0

'Resetthemousepointer.

Screen.MousePointer=0

lblTip="¹²µ¼³ö"+Str（IRow）+"´¦ÎÄ×Ö¡£"

UnBindExcel

UnBindAutoCAD

ExitSub

ERR_GETPARTTEXT:

'Resetthemousepointer.

Screen.MousePointer=0

UnBindExcel

UnBindAutoCAD

lblTip=Err.Number&"Error:

"&Err.Description

EndSub

PrivateSubPutAllText（）

OnErrorGoToERR_PUTALLTEXT

BindAutoCAD

BindExcel

'Changethemousepointertoanhourglass.

Screen.MousePointer=11

DimI,J,IRowAsInteger

IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen

SetoModelSpace=oAutoCAD.ActiveDocument.ModelSpace

IfNotLCase（Right（Trim（txtBook）,4））=".xls"ThentxtBook=txtBook&".xls"

SetoBook=oExcel.Workbooks.Open（FullNameOfFile（App.Path,txtBook）,,False）

DimExistSheetAsBoolean

ExistSheet=False

ForI=1TooBook.Sheets.Count

IfTrim（LCase（oBook.Sheets（I）.Name））=Trim（LCase（txtSheet））Then

SetoSheet=oBook.Sheets（I）'µÚijҳֽ

ExistSheet=I

EndIf

NextI

IfNotExistSheetThenGoToERR_PUTALLTEXT

IRow=0

ForI=0TooModelSpace.Count-1

WithoModelSpace.Item（I）

DoEvents

If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then

lblTip=.textString

ForJ=CInt（txtFromRow）ToCInt（txtToRow）

If.textString=oSheet.Cells（J,txtFromCol）AndNotTrim（oSheet.Cells（J,txtFromCol））=""Then

IRow=IRow+1

.textString=oSheet.Cells（J,txtToCol）

EndIf

NextJ

EndIf

EndWith

NextI

EndIf

OnErrorGoTo0

'Resetthemousepointer.

Screen.MousePointer=0

lblTip="¹²Ìæ»»"+Str（IRow）+"´¦ÎÄ×Ö¡£"

UnBindExcel

UnBindAutoCAD

ExitSub

ERR_PUTALLTEXT:

'Resetthemousepointer.

Screen.MousePointer=0

UnBindExcel

UnBindAutoCAD

lblTip=Err.Number&"Error:

"&Err.Description

EndSub

PrivateSubPutPartText（）

OnErrorGoToERR_PUTPARTTEXT

BindAutoCAD

BindExcel

'Changethemousepointertoanhourglass.

Screen.MousePointer=11

DimI,J,IRowAsInteger

DimSelPartAsString

IfNotoAutoCADIsNothingOrNotoExcelIsNothingThen

Randomize

SelPart="S"&CStr（Int（10000*Rnd）+1）

SetoSelSet=oAutoCAD.ActiveDocument.SelectionSets.Add（SelPart）

AppActivateoAutoCAD.Caption

oSelSet.SelectOnScreen

IfNotLCase（Right（Trim（txtBook）,4））=".xls"ThentxtBook=txtBook&".xls"

SetoBook=oExcel.Workbooks.Open（FullNameOfFile（App.Path,txtBook）,,False）

DimExistSheetAsBoolean

ExistSheet=False

ForI=1TooBook.Sheets.Count

IfTrim（LCase（oBook.Sheets（I）.Name））=Trim（LCase（txtSheet））Then

SetoSheet=oBook.Sheets（I）'µÚijҳֽ

ExistSheet=I

EndIf

NextI

IfNotExistSheetThenGoToERR_PUTPARTTEXT

IRow=0

ForI=0TooSelSet.Count-1

WithoSelSet.Item（I）

DoEvents

If.EntityName="AcDbMText"Or.EntityName="AcDbText"Then

lblTip=.textString

ForJ=CInt（txtFromRow）ToCInt（txtToRow）

If.textString=oSheet.Cells（J,txtFromCol）AndNotTrim（oSheet.Cells（J,txtFromCol））=""Then

IRow=IRow+1

.textString=oSheet.Cells（J,txtToCol）

EndIf

NextJ

EndIf

EndWith

NextI

EndIf

OnErrorGoTo0

'Resetthemousepointer.

Screen.MousePointer=0

lblTip="¹²Ìæ»»"+Str（IRow）+"´¦ÎÄ×Ö¡£"

UnBindExcel

UnBindAutoCAD

ExitSub

ERR_PUTPARTTEXT:

'Resetthemousepointer.

Screen.MousePointer=0

UnBindExcel

UnBindAutoCAD

lblTip=Err.Number&"Error:

"&Err.Description

EndSub

PrivateSubTranAllText（）

OnErrorGoToERR_TRANALLTEXT

BindAutoCAD

'Changethemousepointertoanhourglass.

Screen.MousePointer=11

DimI,ICountAsInteger

Diminspoi（0To2）AsDouble

DimpntAsVariant

ICount=0

IfNotoAutoCADIsNothingThen

SetoModelSpace=oAutoCAD.ActiveDocument.ModelSpace

IfErr.Number<>0Then

Err.Clear

ExitSub

EndIf

ForI=oModelSpace.Count-1To0Step-1

shpPro.Width=（1-I/oModelSpace.Count）*picBack.Width

WithoModelSpace.Item（I）

DoEvents

If.EntityName="AcDbMText"Then

.textString=TrimMText（.textString）

.StyleName="Standard"

ICount=ICount+1

lblTip.Caption="ÐÞ¸Ä×Ö·û¸öÊý£º"&CStr（ICount）

EndIf

If.EntityName="AcDbText"Then

pnt=.insertionPoint

inspoi（0）=pnt（0）

inspoi

（1）=pnt

（1）+.Height

inspoi

（2）=pnt

（2）

SetoMText=oModelSpace.AddMtext（inspoi,.Height*256,TrimMText（.textString））

oMText.Height=.Height

oMText.StyleName="Standard"

.Delete

ICount=ICount+1

lblTip.Caption="ÐÞ¸Ä×Ö·û¸öÊý£º"&CStr（ICount）

EndIf

EndWith

NextI

shpPro.Width=picBack.Width

EndIf

SetoTextStyles=oAutoCAD.ActiveDocument.TextStyles（"standard"）

oTextStyles.fontfile="times.ttf"'TimesNewRoman

OnErrorGoTo0

'Resetthemousepointer.

Screen.MousePointer=0

UnBindAutoCAD

ExitSub

ERR_TRANALLTEXT:

'Resetthemousepointer.

Screen.MousePointer=0

UnBindAutoCAD

lblTip=Err.Number&"Error:

"&Err.Description

EndSub

PrivateSubTranPartText（）

OnErrorGoToER