Option Explicit.docx
《Option Explicit.docx》由会员分享，可在线阅读，更多相关《Option Explicit.docx（13页珍藏版）》请在冰豆网上搜索。
OptionExplicit
OptionExplicit
Constpi=3.1415926535898
Privatea,b,c,alpha,e,e2,w,VAsDouble
PrivateB1,L1,B2,L2AsDouble
PrivatesAsDouble
PrivateA1,A2AsDouble
PrivateSubgetellipseparameter（）
a=6378245
b=6356752.3142
c=a^2/b
alpha=（a-b）/a
e=Sqr（a^2-b^2）/a
e2=Sqr（a^2-b^2）/b
EndSub
PrivateFunctioncomputerw（）
w=Sqr（1-e^2*（Sin（B1）^2））
V=w*（a/b）
EndFunction
FunctionComputation（STARTLAT,STARTLONG,ANGLE1,DISTANCEAsDouble）AsString'''''正算
Dimsinu1,cosu1,sinA0,cotq1,sin2q1,cos2q1,cos2A0AsDouble
Dimk2,q0,sin2q1q0,cos2q1q0AsDouble
DimqAsDouble
DimthetaAsDouble
Dimaa,BB,cc,EE22,AAlpha,BBetaAsDouble
Dimsinu2,lamudaAsDouble
Dime1AsDouble
DimW1AsDouble
B1=STARTLAT
L1=STARTLONG
A1=ANGLE1
s=DISTANCE
Callgetellipseparameter
IfB1=0Then
IfA1=90Then
A2=270
B2=0
L2=L1+s/a*180/pi
EndIf
IfA1=270Then
A2=90
B2=0
L2=L1-s/a*180/pi
EndIf
ExitFunction
EndIf
B1=rad（B1）
L1=rad（L1）
A1=rad（A1）
Callcomputerw
e1=e
W1=w
sinu1=Sin（B1）*Sqr（1-e1*e1）/W1
cosu1=Cos（B1）/W1
sinA0=cosu1*Sin（A1）
cotq1=cosu1*Cos（A1）
sin2q1=2*cotq1/（cotq1^2+1）
cos2q1=（cotq1^2-1）/（cotq1^2+1）
cos2A0=1-sinA0^2
e2=Sqr（a^2-b^2）/b
k2=e2*e2*cos2A0
aa=b*（1+k2/4-3*k2*k2/64+5*k2*k2*k2/256）
BB=b*（k2/8-k2*k2/32+15*k2*k2*k2/1024）
cc=b*（k2*k2/128-3*k2*k2*k2/512）
e2=e1*e1
AAlpha=（e2/2+e2*e2/8+e2*e2*e2/16）-（e2*e2/16+e2*e2*e2/16）*cos2A0+（3*e2*e2*e2/128）*cos2A0*cos2A0
BBeta=（e2*e2/32+e2*e2*e2/32）*cos2A0-（e2*e2*e2/64）*cos2A0*cos2A0
q0=（s-（BB+cc*cos2q1）*sin2q1）/aa
sin2q1q0=sin2q1*Cos（2*q0）+cos2q1*Sin（2*q0）
cos2q1q0=cos2q1*Cos（2*q0）-sin2q1*Sin（2*q0）
q=q0+（BB+5*cc*cos2q1q0）*sin2q1q0/aa
'theta=（AAlpha*q+BBeta*（sin2q1q0-sin2q1））*sinA0
theta=（AAlpha*q+BBeta*（sin2q1q0-sin2q1））*sinA0
sinu2=sinu1*Cos（q）+cosu1*Cos（A1）*Sin（q）
B2=Atn（sinu2/（Sqr（1-e1*e1）*Sqr（1-sinu2*sinu2）））*180/pi
lamuda=Atn（Sin（A1）*Sin（q）/（cosu1*Cos（q）-sinu1*Sin（q）*Cos（A1）））*180/pi
If（Sin（A1）>0）Then
If（Sin（A1）*Sin（q）/（cosu1*Cos（q）-sinu1*Sin（q）*Cos（A1））>0）Then
lamuda=Abs（lamuda）
Else
lamuda=180-Abs（lamuda）
EndIf
Else
If（Sin（A1）*Sin（q）/（cosu1*Cos（q）-sinu1*Sin（q）*Cos（A1））>0）Then
lamuda=Abs（lamuda）-180
Else
lamuda=-Abs（lamuda）
EndIf
EndIf
L2=L1*180/pi+lamuda-theta*180/pi
A2=Atn（cosu1*Sin（A1）/（cosu1*Cos（q）*Cos（A1）-sinu1*Sin（q）））*180/pi
If（Sin（A1）>0）Then
If（cosu1*Sin（A1）/（cosu1*Cos（q）*Cos（A1）-sinu1*Sin（q））>0）Then
A2=180+Abs（A2）
Else
A2=360-Abs（A2）
EndIf
Else
If（cosu1*Sin（A1）/（cosu1*Cos（q）*Cos（A1）-sinu1*Sin（q））>0）Then
A2=Abs（A2）
Else
A2=180-Abs（A2）
EndIf
EndIf
Computation=format（L2,"0.00000000"）&","&format（B2,"0.00000000"）
EndFunction
PrivateFunctionrad（ByValangle_dAsDouble）AsDouble
rad=angle_d*pi/180
EndFunction
vb操作XML文件 [原创2008-12-510:
17:
05]
字号：
大 中 小
1.新建一个VB应用程序,引用MicrosoftXML,version2.0
2.建一个类,把以下代码复制到类里:
PrivateDeclareFunctionPathFileExistsLib"shlwapi.dll"Alias"PathFileExistsA"（ByValpszPathAsString）AsLong
PrivateTypeRecord
NameAsString
ValueAsString
EndType
PublicRecordCountAsInteger'总列
PrivateNowCountAsInteger'当前列
Privateg_xml_documentAsDOMDocument
Privateg_sPathFileAsString
Privateg_RootNodeAsIXMLDOMNode
PrivateRecordSet（）AsRecord
PublicFunctionConnectXml（sPathFileAsString）
g_sPathFile=sPathFile
IfPathFileExists（sPathFile）=1Then
'载入文件
Setg_xml_document=NewDOMDocument
g_xml_document.LoadsPathFile
Ifg_xml_document.documentElementIsNothingThen
Setg_RootNode=g_xml_document.createElement（"Root"）
g_xml_document.appendChildg_RootNode
Else
Setg_RootNode=g_xml_document.selectSingleNode（"Root"）
Ifg_RootNodeIsNothingThen
Setg_RootNode=g_xml_document.createElement（"Root"）
g_xml_document.appendChildg_RootNode
EndIf
EndIf
Else
Setg_xml_document=NewDOMDocument
Setg_RootNode=g_xml_document.createElement（"Root"）
g_xml_document.appendChildg_RootNode
EndIf
EndFunction
PublicFunctionOptXml（strsqlAsString）
DimsSqlAsString
DimsPar（）AsString,strParAsString
DimsValues（）AsString,strValueAsString
DimsTempAsString
DimsTableAsString
DimiLenAsInteger
sSql=Trim（Left（strsql,InStr（1,strsql,""）））
SelectCaseLCase（sSql）
CaseLCase（"insert"）
iLen=InStr（1,strsql,"（"）-13
sTable=Mid（strsql,13,iLen）
iLen=InStr（1,strsql,"）"）-InStr（1,strsql,"（"）-1
IfiLen>0Then
strPar=Mid（strsql,InStr（1,strsql,"（"）+1,iLen）
Else
strPar=""
EndIf
strsql=Mid（strsql,InStr（1,strsql,"values（"）+8）
strValue=Mid（strsql,1,Len（strsql）-1）
InsertXmlsTable,strPar,strValue
CaseLCase（"update"）
iLen=InStr（1,LCase（strsql）,"set"）-8
sTable=Mid（strsql,8,iLen）
IfInStr（1,LCase（strsql）,"where"）>0Then
iLen=InStr（1,LCase（strsql）,"where"）-InStr（1,strsql,"set"）-5
strPar=Mid（strsql,InStr（1,LCase（strsql）,"set"）+5,iLen）
Else
strPar=Mid（strsql,InStr（1,LCase（strsql）,"set"）+5）
EndIf
IfInStr（1,LCase（strsql）,"where"）>0Then
strValue=Trim（Mid（strsql,InStr（1,LCase（strsql）,"where"）+6））
Else
strValue=""
EndIf
UpdateXmlsTable,strPar,strValue
CaseLCase（"delete"）
iLen=InStr（1,LCase（strsql）,"where"）
IfiLen=0ThensTable=Mid（strsql,13）ElsesTable=Mid（strsql,13,iLen-14）
IfInStr（1,LCase（strsql）,"where"）>0Then
strValue=Trim（Mid（strsql,InStr（1,LCase（strsql）,"where"）+6））
Else
strValue=""
EndIf
DeleteXmlsTable,strValue
CaseLCase（"select"）
iLen=InStr（1,LCase（strsql）,"from"）
strPar=Trim（Mid（strsql,8,iLen-8））
IfInStr（1,LCase（strsql）,"where"）>0Then
sTable=Mid（strsql,iLen+5,InStr（1,LCase（strsql）,"where"）-iLen-5）
strValue=Trim（Mid（strsql,InStr（1,LCase（strsql）,"where"）+6））
Else
sTable=Mid（strsql,iLen+5）
strValue=""
EndIf
SeleteXmlsTable,strPar,strValue
CaseElse
ExitFunction
EndSelect
EndFunction
'/************************************************************************************/
'/函数功能：
添加节点
'/参数说明：
参数一:
表名,参数二:
参数,参数三:
每个参数的值,参数四:
XML文件
'/编写人：
于莹莹
'/编写日期：
2008-11-29
'/************************************************************************************/
PrivateFunctionInsertXml（sTableAsString,strParAsString,strValueAsString）AsBoolean
DimValueNodeAsIXMLDOMNode
DimsPar（）AsString
DimsValue（）AsString
DimiAsInteger
OnErrorGoToErrMsg
SetValueNode=g_RootNode.ownerDocument.createElement（sTable）
g_RootNode.appendChildValueNode
sPar=Split（strPar,","）:
sValue=Split（strValue,","）
Fori=0ToUBound（sPar）
WriteXmlFileValueNode,sPar（i）,Trim（Replace（sValue（i）,"'",""））
Next
g_xml_document.saveg_sPathFile
InsertXml=True
ExitFunction
ErrMsg:
InsertXml=False
EndFunction
'/************************************************************************************/
'/函数功能：
XML文件中,添加节点
'/参数说明：
参数一:
父节点,参数二:
添加的节点名称,参数三:
添加的节点内容
'/编写人：
于莹莹
'/编写日期：
2008-11-26
'/************************************************************************************/
PrivateFunctionWriteXmlFile（ByValparentAsIXMLDOMNode,ByValnode_nameAsString,ByValnode_valueAsString）
Dimnew_nodeAsIXMLDOMNode
Setnew_node=parent.ownerDocument.createElement（node_name）
new_node.Text=node_value
parent.appendChildnew_node
EndFunction
'/************************************************************************************/
'/函数功能：
修改节点
'/参数说明：
参数一:
表名,参数二:
要改变的内容,参数三:
Where的值,参数四:
XML文件
'/编写人：
于莹莹
'/编写日期：
2008-11-29
'/************************************************************************************/
升级会员 