vba中使用api串口通信

'ThisVBmoduleisacollectionofroutinestoperformserialportI/Owithout

'usingtheMicrosoftCommControlcomponent.ThismoduleusestheWindowsAPI'toperformtheoverlappedI/Ooperationsnecessaryforserialcommunications.

I

'Theroutinecanhandleupto4serialportswhichareidentifiedwitha

'PortID.

I

'Allroutines(withtheexceptionofCommReadandCommWrite)returnanerror

'codeor0ifnoerroroccurs.TheroutineCommGetErrorcanbeusedtoget

'thecompleteerrormessage.

PublicConstants

'OutputControlLines(CommSetLine)

ConstLINE_BREAK=1

ConstLINE_DTR=2

ConstLINE_RTS=3'InputControlLines(CommGetLine)

ConstLINE_CTS=&H10&

ConstLINE_DSR=&H20&

ConstLINE_RING=&H40&

ConstLINE_RLSD=&H80&

ConstLINE_CD=&H80&

SystemConstants

PrivateConstERROR_IO_INCOMPLETE=996&

PrivateConstERROR_IO_PENDING=997

PrivateConstGENERIC_READ=&H

PrivateConstGENERIC_WRITE=&H

PrivateConstFILE_ATTRIBUTE_NORMAL=&H80

PrivateConstFILE_FLAG_OVERLAPPED=&H

PrivateConstFORMAT_MESSAGE_FROM_SYSTEM=&H1000

PrivateConstOPEN_EXISTING=3

'COMMFunctions

PrivateConstMS_CTS_ON=&H10&

PrivateConstMS_DSR_ON=&H20&

PrivateConstMS_RING_ON=&H40&

PrivateConstMS_RLSD_ON=&H80&

PrivateConstPURGE_RXABORT=&H2

PrivateConstPURGE_RXCLEAR=&H8

PrivateConstPURGE_TXABORT=&H1

PrivateConstPURGE_TXCLEAR=&H4'COMMEscapeFunctionsPrivateConstCLRBREAK=9PrivateConstCLRDTR=6PrivateConstCLRRTS=4PrivateConstSETBREAK=8PrivateConstSETDTR=5PrivateConstSETRTS=3

SystemStructures

PrivateTypeCOMSTATfBitFieldsAsLong'SeeCommentincbInQueAsLongcbOutQueAsLong

EndType

PrivateTypeCOMMTIMEOUTSReadIntervalTimeoutAsLongReadTotalTimeoutMultiplierAsLongReadTotalTimeoutConstantAsLongWriteTotalTimeoutMultiplierAsLongWriteTotalTimeoutConstantAsLongEndType'TheDCBstructuredefinesthecontrolsettingforaserial'communicationsdevice.

I

PrivateTypeDCB

DCBlengthAsLongBaudRateAsLongfBitFieldsAsLong'SeeCommentsinwReservedAsIntegerXonLimAsIntegerXoffLimAsIntegerByteSizeAsByteParityAsByteStopBitsAsByteXonCharAsByteXoffCharAsByteErrorCharAsByteEofCharAsByteEvtCharAsBytewReserved1AsInteger'Reserved;DoNotUseEndType

PrivateTypeOVERLAPPEDInternalAsLongInternalHighAsLongoffsetAsLongOffsetHighAsLonghEventAsLong

EndType

PrivateTypeSECURITY_ATTRIBUTESnLengthAsLonglpSecurityDescriptorAsLongbInheritHandleAsLong

EndType

SystemFunctions'FillsaspecifiedDCBstructurewithvaluesspecifiedin

'adevice-controlstring.

I

PrivateDeclareFunctionBuildCommDCBLib"kernel32"Alias"BuildCommDCBA"_(ByVallpDefAsString,lpDCBAsDCB)AsLong

I

'Retrievesinformationaboutacommunicationserrorandreports

'thecurrentstatusofacommunicationsdevice.Thefunctionis

'calledwhenacommunicationserroroccurs,anditclearsthe

'device'serrorflagtoenableadditionalinputandoutput

'(I/O)operations.

I

PrivateDeclareFunctionClearCommErrorLib"kernel32"_

(ByValhFileAsLong,lpErrorsAsLong,lpStatAsCOMSTAT)AsLong

I

'Closesanopencommunicationsdeviceorfilehandle.

I

PrivateDeclareFunctionCloseHandleLib"kernel32"(ByValhObjectAsLong)AsLong

I

'Createsoropensacommunicationsresourceandreturnsahandle

'thatcanbeusedtoaccesstheresource.

I

PrivateDeclareFunctionCreateFileLib"kernel32"Alias"CreateFileA"_(ByVallpFileNameAsString,ByValdwDesiredAccessAsLong,_ByValdwShareModeAsLong,lpSecurityAttributesAsAny,_ByValdwCreationDispositionAsLong,ByValdwFlagsAndAttributesAsLong,_ByValhTemplateFileAsLong)AsLong

I

'Directsaspecifiedcommunicationsdevicetoperformafunction.

PrivateDeclareFunctionEscapeCommFunctionLib"kernel32"_

(ByValnCidAsLong,ByValnFuncAsLong)AsLong

I

'Formatsamessagestringsuchasanerrorstringreturned

'byanoherfunction.

I

PrivateDeclareFunctionFormatMessageLib"kernel32"Alias"FormatMessageA"_(ByValdwFlagsAsLong,lpSourceAsAny,ByValdwMessageIdAsLong,_ByValdwLanguageIdAsLong,ByVallpBufferAsString,ByValnSizeAsLong,_ArgumentsAsLong)AsLong

I

'Retrievesmodemcontrol-registervalues.

I

PrivateDeclareFunctionGetCommModemStatusLib"kernel32"_

(ByValhFileAsLong,lpModemStatAsLong)AsLong

I

'Retrievesthecurrentcontrolsettingsforaspecified

'communicationsdevice.

I

PrivateDeclareFunctionGetCommStateLib"kernel32"_

(ByValnCidAsLong,lpDCBAsDCB)AsLong

I

'Retrievesthecallingthread'slast-errorcodevalue.

I

PrivateDeclareFunctionGetLastErrorLib"kernel32"()AsLong

I

'Retrievestheresultsofanoverlappedoperationonthe

'specifiedfile,namedpipe,orcommunicationsdevice.

I

PrivateDeclareFunctionGetOverlappedResultLib"kernel32"_

(ByValhFileAsLong,lpOverlappedAsOVERLAPPED,_lpNumberOfBytesTransferredAsLong,ByValbWaitAsLong)AsLong

I

'Discardsallcharactersfromtheoutputorinputbufferofa

'specifiedcommunicationsresource.Itcanalsoterminate

'pendingreadorwriteoperationsontheresource.

I

PrivateDeclareFunctionPurgeCommLib"kernel32"_

(ByValhFileAsLong,ByValdwFlagsAsLong)AsLong

I

'Readsdatafromafile,startingatthepositionindicatedbythe

'filepointer.Afterthereadoperationhasbeencompleted,the

'filepointerisadjustedbythenumberofbytesactuallyread,

'unlessthefilehandleiscreatedwiththeoverlappedattribute.

'Ifthefilehandleiscreatedforoverlappedinputandoutput

'(I/O),theapplicationmustadjustthepositionofthefilepointer

'afterthereadoperation.

PrivateDeclareFunctionReadFileLib"kernel32"

(ByValhFileAsLong,ByVallpBufferAsString,_

ByValnNumberOfBytesToReadAsLong,ByReflpNumberOfBytesReadAsLong,_lpOverlappedAsOVERLAPPED)AsLong

I

'Configuresacommunicationsdeviceaccordingtothespecifications

'inadevice-controlblock(aDCBstructure).Thefunction

'reinitializesallhardwareandcontrolsettings,butitdoesnot

'emptyoutputorinputqueues.

I

PrivateDeclareFunctionSetCommStateLib"kernel32"_

(ByValhCommDevAsLong,lpDCBAsDCB)AsLong

I

'Setsthetime-outparametersforallreadandwriteoperationsona

'specifiedcommunicationsdevice.

I

PrivateDeclareFunctionSetCommTimeoutsLib"kernel32"_

(ByValhFileAsLong,lpCommTimeoutsAsCOMMTIMEOUTS)AsLong

I

'Initializesthecommunicationsparametersforaspecified

'communicationsdevice.

I

PrivateDeclareFunctionSetupCommLib"kernel32"_

(ByValhFileAsLong,ByValdwInQueueAsLong,ByValdwOutQueueAsLong)AsLong

I

'Writesdatatoafileandisdesignedforbothsynchronousanda

'synchronousoperation.Thefunctionstartswritingdatatothefile

'atthepositionindicatedbythefilepointer.Afterthewrite

'operationhasbeencompleted,thefilepointerisadjustedbythe

'numberofbytesactuallywritten,exceptwhenthefileisopenedwith

'FILE_FLAG_OVERLAPPED.Ifthefilehandlewascreatedforoverlapped

'inputandoutput(I/O),theapplicationmustadjustthepositionof

'thefilepointerafterthewriteoperationisfinished.

I

PrivateDeclareFunctionWriteFileLib"kernel32"_

(ByValhFileAsLong,ByVallpBufferAsString,_

ByValnNumberOfBytesToWriteAsLong,lpNumberOfBytesWrittenAsLong,_lpOverlappedAsOVERLAPPED)AsLong

PrivateDeclareSubAppSleepLib"kernel32"Alias"Sleep"(ByValdwMillisecondsAsLong)

ProgramConstants

PrivateConstMAX_PORTS=4

ProgramStructures

PrivateTypeCOMM_ERRORlngErrorCodeAsLongstrFunctionAsStringstrErrorMessageAsString

EndType

PrivateTypeCOMM_PORTlngHandleAsLongblnPortOpenAsBooleanudtDCBAsDCB

EndType

ProgramStorage

PrivateudtCommOverlapAsOVERLAPPED

PrivateudtCommErrorAsCOMM_ERROR

PrivateudtPorts(1ToMAX_PORTS)AsCOMM_PORT

GetSystemMessage-Getssystemerrortextforthespecifiederrorcode.

PublicFunctionGetSystemMessage(lngErrorCodeAsLong)AsString

DimintPosAsInteger

DimstrMessageAsString,strMsgBuffAsString*256

255,0)

CallFormatMessage(FORMAT_MESSAGE_FROM_SY0S,TlnEgME,rrorCode,0,strMsgBuff,intPos=InStr(1,strMsgBuff,vbNullChar)

IfintPos>0ThenstrMessage=Trim$(Left$(strMsgBuff,intPos-1))

ElsestrMessage=Trim$(strMsgBuff)

EndIf

GetSystemMessage=strMessage

EndFunction

PublicFunctionPauseApp(PauseInSecondsAsLong)

CallAppSleep(PauseInSeconds*1000)

EndFunction

CommOpen-Opens/Initializesserialport.

Parameters:intPortID-PortIDusedwhenportwasopened.

strPort-COMportname.(COM1,COM2,COM3,COM4)strSettings-Communicationsettings.

Example:"baud=9600parity=Ndata=8stop=1"

Returns:

ErrorCode-0=NoError.

PublicFunctionCommOpen(intPortIDAsInteger,strPortAsString,_strSettingsAsString)AsLong

DimlngStatusAsLong

DimudtCommTimeOutsAsCOMMTIMEOUTS

OnErrorGoToRoutine_Error

'Seeifportalreadyinuse.

IfudtPorts(intPortID).blnPortOpenThenlngStatus=-1WithudtCommError

.lngErrorCode=lngStatus.strFunction="CommOpen".strErrorMessage="Portinuse."

EndWith

GoToRoutine_Exit

EndIf

'Openserialport.udtPorts(intPortID).lngHandle=CreateFile(strPort,GENERIC_READOr_

GENERIC_WRITE,0,ByVal0&,OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0)

IfudtPorts(intPortID).lngHandle=-1ThenlngStatus=SetCommError("CommOpen(CreateFile)")GoToRoutine_Exit

EndIf

udtPorts(intPortID).blnPortOpen=True

'Setupdevicebuffers(1Keach).lngStatus=SetupComm(udtPorts(intPortID).lngHandle,1024,1024)

IflngStatus=0ThenlngStatus=SetCommError("CommOpen(SetupComm)")GoToRoutine_Exit

'Purgebuffers.

lngStatus=PurgeComm(udtPorts(intPortID).lngHandle,PURGE_TXABORTOr_PURGE_RXABORTOrPURGE_TXCLEAROrPURGE_RXCLEAR)

IflngStatus=0Then

lngStatus=SetCommError("CommOpen(PurgeComm)")

GoToRoutine_Exit

EndIf

'Setserialporttimeouts.

WithudtCommTimeOuts.ReadIntervalTimeout=-1.ReadTotalTimeoutMultiplier=0.ReadTotalTimeoutConstant=1000.WriteTotalTimeoutMultiplier=0.WriteTotalTimeoutMultiplier=1000

EndWith

lngStatus=SetCommTimeouts(udtPorts(intPortID).lngHandle,udtCommTimeOuts)

IflngStatus=0Then

lngStatus=SetCommError("CommOpen(SetCommTimeouts)")GoToRoutine_Exit

EndIf

'Getthecurrentstate(DCB).

lngStatus=GetCommState(udtPorts(intPortID).lngHandle,_udtPorts(intPortID).udtDCB)

IflngStatus=0Then

lngStatus=SetCommError("CommOpen(GetCommState)")

GoToRoutine_Exit

EndIf

'ModifytheDCBtoreflectthedesiredsettings.

lngStatus=BuildCommDCB(strSettings,udtPorts(intPortID).udtDCB)

IflngStatus=0Then

lngStatus=SetCommError("CommOpen(BuildCommDCB)")GoToRoutine_Exit

EndIf

'Setthenewstate.

lngStatus=SetCommState(udtPorts(intPortID).lngHandle,_udtPorts(intPortID).udtDCB)

IflngStatus=0Then

lngStatus=SetCommError("CommOpen(SetCommState)")

GoToRoutine_Exit

EndIf

lngStatus=0

Routine_Exit:

CommOpen=lngStatus

ExitFunction

Routine_Error:

lngStatus=

WithudtCommError.lngErrorCode=lngStatus.strFunction="CommOpen".strErrorMessage=

EndWith

ResumeRoutine_Exit

EndFunction

PrivateFunctionSetCommError(strFunctionAsString)AsLong

WithudtCommError.lngErrorCode=.strFunction=strFunction.strErrorMessage=GetSystemMessage(.lngErrorCode)SetCommError=.lngErrorCode

EndWith

EndFunction

PrivateFunctionSetCommErrorEx(strFunctionAsString,lngHndAsLong)AsLongDimlngErrorFlagsAsLongDimudtCommStatAsCOMSTAT

WithudtCommError.lngErrorCode=GetLastError.strFunction=strFunction.strErrorMessage=GetSystemMessage(.lngErrorCode)

CallClearCommError(lngHnd,lngErrorFlags,udtCommStat)

.strErrorMessage=.strErrorMessage&"COMMErrorFlags="&_Hex$(lngErrorFlags)

SetCommErrorEx=.lngErrorCode

EndWith

CommSet-Modifiestheserialportsettings.

Parameters:

intPortID-PortIDusedwhenportwasopened.strSettings-Communicationsettings.

Example:"baud=9600parity=Ndata=8stop=1"

Returns:

ErrorCode-0=NoError.

PublicFunctionCommSet(intPortIDAsInteger,strSettingsAsString)AsLong

DimlngStatusAsLong

OnErrorGoToRoutine_Error

lngStatus=GetCommState(udtPorts(intPortID).lngHandle,_udtPorts(intPortID).udtDCB)

IflngStatus=0ThenlngStatus=SetCommError("CommSet(GetCommState)")GoToRoutine_Exit

EndIf

lngStatus=BuildCommDCB(strSettings,udtPorts(intPortID).udtDCB)

IflngStatus=0ThenlngStatus=SetCommError("CommSet(BuildCommDCB)")GoToRoutine_Exit

EndIf

lngStatus=SetCommState(udtPorts(intPortID).lngHandle,_udtPorts(intPortID).udtDCB)

IflngStatus=0ThenlngStatus=SetCommError("CommSet(SetCommState)")GoToRoutine_Exit

EndIf

lngStatus=0

Routine_Exit:

CommSet=lngStatus

ExitFunction

Routine_Error:

lngStatus=

WithudtCommError.lngErrorCode=lngStatus.strFunction="CommSet".strErrorMessage=

EndWith

ResumeRoutine_Exit

EndFunction

CommClose-Closetheserialport.

Parameters:

intPortID-PortIDusedwhenportwasopened.

Returns:

ErrorCode-0=NoError.

PublicFunctionCommClose(intPortIDAsInteger)AsLong

DimlngStatusAsLong

OnErrorGoToRoutine_Error

IfudtPorts(intPortID).blnPortOpenThen

lngStatus=CloseHandle(udtPorts(intPortID).lngHandle)

IflngStatus=0Then

lngStatus=SetCommError("CommClose(CloseHandle)")

GoToRoutine_Exit

EndIf

udtPorts(intPortID).blnPortOpen=False

EndIf

lngStatus=0

Routine_Exit:

CommClose=lngStatus

ExitFunction

Routine_Error:

lngStatus=

WithudtCommError

.lngErrorCode=lngStatus

.strFunction="CommClose"

.strErrorMessage=

EndWith

ResumeRoutine_Exit

CommFlush-Flushthesendandreceiveserialportbuffers.Parameters:

intPortID-PortIDusedwhenportwasopened.Returns:

ErrorCode-0=NoError.

PublicFunctionCommFlush(intPortIDAsInteger)AsLong

DimlngStatusAsLong

OnErrorGoToRoutine_Error

lngStatus=PurgeComm(udtPorts(intPortID).lngHandle,PURGE_TXABORTOr_PURGE_RXABORTOrPURGE_TXCLEAROrPURGE_RXCLEAR)

IflngStatus=0ThenlngStatus=SetCommError("CommFlush(PurgeComm)")GoToRoutine_Exit

EndIf

lngStatus=0

Routine_Exit:

CommFlush=lngStatus

ExitFunction

Routine_Error:

lngStatus=

WithudtCommError.lngErrorCode=lngStatus.strFunction="CommFlush".strErrorMessage=

EndWith

ResumeRoutine_Exit

EndFunction

CommRead-Readserialportinputbuffer.

Parameters:

intPortID-PortIDusedwhenportwasopened.strData-Databuffer.

lngSize-Maximumnumberofbytestoberead.

PublicFunctionCommRead(intPortIDAsInteger,strDataAsString,_lngSizeAsLong)AsLong

DimlngStatusAsLong

DimlngRdSizeAsLong,lngBytesReadAsLong

DimlngRdStatusAsLong,strRdBufferAsString*1024

DimlngErrorFlagsAsLong,udtCommStatAsCOMSTAT

OnErrorGoToRoutine_Error

strData=""lngBytesRead=0

DoEvents

'Clearanypreviouserrorsandgetcurrentstatus.

lngStatus=ClearCommError(udtPorts(intPortID).lngHandle,lngErrorFlags,_udtCommStat)

IflngStatus=0ThenlngBytesRead=-1lngStatus=SetCommError("CommRead(ClearCommError)")GoToRoutine_Exit

EndIf

If>0Then

If>lngSizeThenlngRdSize=

ElselngRdSize=lngSize

EndIf

ElselngRdSize=0

EndIf

IflngRdSizeThenlngRdStatus=ReadFile(udtPorts(intPortID).lngHandle,strRdBuffer,_lngRdSize,lngBytesRead,udtCommOverlap)

IflngRdStatus=0ThenlngStatus=GetLastError

IflngStatus=ERROR_IO_PENDINGThen

'Waitforreadtocomplete.

'Thisfunctionwilltimeoutaccordingtothe

'variable.

'Everytimeittimesout,checkforporterrors.

'Loopuntiloperationiscomplete.

WhileGetOverlappedResult(udtPorts(intPortID).lngHandle,_udtCommOverlap,lngBytesRead,True)=0

lngStatus=GetLastError

IflngStatusERROR_IO_INCOMPLETEThenlngBytesRead=-1lngStatus=SetCommErrorEx(_

"CommRead(GetOverlappedResult)",_udtPorts(intPortID).lngHandle)

GoToRoutine_Exit

EndIf

Wend

Else

'Someothererroroccurred.

lngBytesRead=-1

lngStatus=SetCommErrorEx("CommRead(ReadFile)",_udtPorts(intPortID).lngHandle)

GoToRoutine_Exit

EndIf

EndIf

strData=Left$(strRdBuffer,lngBytesRead)

EndIf

Routine_Exit:

CommRead=lngBytesRead

ExitFunction

Routine_Error:

lngBytesRead=-1

lngStatus=

WithudtCommError

.lngErrorCode=lngStatus

.strFunction="CommRead"

.strErrorMessage=

EndWith

ResumeRoutine_ExitEndFunction

CommWrite-Outputdatatotheserialport.

Parameters:

intPortID-PortIDusedwhenportwasopened.strData-Datatobetransmitted.

PublicFunctionCommWrite(intPortIDAsInteger,strDataAsString)AsLong

DimiAsInteger

DimlngStatusAsLong,lngSizeAsLong

DimlngWrSizeAsLong,lngWrStatusAsLong

OnErrorGoToRoutine_Error

'Getthelengthofthedata.

lngSize=Len(strData)

'Outputthedata.

lngWrStatus=WriteFile(udtPorts(intPortID).lngHandle,strData,lngSize,_lngWrSize,udtCommOverlap)

'Notethatnormallythefollowingcodewillnotexecutebecausethedriver

'cacheswriteoperations.SmallI/Orequests(uptoseveralthousandbytes)

'willnormallybeacceptedimmediatelyandWriteFilewillreturntrueeven

'thoughanoverlappedoperationwasspecified.

DoEvents

IflngWrStatus=0Then

lngStatus=GetLastError

IflngStatus=0Then

GoToRoutine_Exit

ElseIflngStatus=ERROR_IO_PENDINGThen

'Weshouldwaitforthecompletionofthewriteoperationsoweknow

'ifitworkedornot.

I

'Thisisonlyonewaytodothis.Itmightbebeneficialtoplacethe

'writingoperationinaseparatethreadsothatblockingoncompletion

'willnotnegativelyaffecttheresponsivenessoftheUI.

I

'Ifthewritetakeslongenoughtocomplete,thisfunctionwilltimeout

'accordingtothevariable.

'Atthattimewecancheckforerrorsandthenwaitsomemore.

'Loopuntiloperationiscomplete.

WhileGetOverlappedResult(udtPorts(intPortID).lngHandle,_udtCommOverlap,lngWrSize,True)=0

lngStatus=GetLastError

IflngStatusERROR_IO_INCOMPLETEThenlngStatus=SetCommErrorEx(_

"CommWrite(GetOverlappedResult)",_

udtPorts(intPortID).lngHandle)

GoToRoutine_Exit

EndIf

Wend

Else

'Someothererroroccurred.

lngWrSize=-1

lngStatus=SetCommErrorEx("CommWrite(WriteFile)",udtPorts(intPortID).lngHandle)

GoToRoutine_Exit

EndIf

EndIf

Fori=1To10

DoEvents

Next

Routine_Exit:

CommWrite=lngWrSize

ExitFunction

Routine_Error:

lngStatus=

WithudtCommError

.lngErrorCode=lngStatus

.strFunction="CommWrite"

.strErrorMessage=

EndWith

ResumeRoutine_Exit

EndFunction

CommGetLine-Getthestateofselectedserialportcontrollines.

Parameters:intPortID-PortIDusedwhenportwasopened.

intLine-Serialportline.CTS,DSR,RING,RLSD(CD)blnState-Returnsstateofline(ClearedorSet).

Returns:

ErrorCode-0=NoError.

PublicFunctionCommGetLine(intPortIDAsInteger,intLineAsInteger,_blnStateAsBoolean)AsLong

DimlngStatusAsLong

DimlngComStatusAsLong,lngModemStatusAsLong

OnErrorGoToRoutine_Error

lngStatus=GetCommModemStatus(udtPorts(intPortID).lngHandle,lngModemStatus)

IflngStatus=0ThenlngStatus=SetCommError("CommReadCD(GetCommModemStatus)")GoToRoutine_Exit

EndIf

If(lngModemStatusAndintLine)ThenblnState=True

Else

blnState=False

EndIf

lngStatus=0

Routine_Exit:

CommGetLine=lngStatus

ExitFunction

Routine_Error:

lngStatus=

WithudtCommError.lngErrorCode=lngStatus.strFunction="CommReadCD".strErrorMessage=

EndWith

ResumeRoutine_Exit

EndFunction

CommSetLine-Setthestateofselectedserialportcontrollines.

Parameters:intPortID-PortIDusedwhenportwasopened.intLine-Serialportline.BREAK,DTR,RTS

Note:BREAKactuallysetsorclearsa"break"