dim區塊鏈
❶ vba如何將一個單元格區域定義為數組，並判斷另一個數組對它賦值
下面是簡單的代碼示例，解釋參見注釋：
Option Explicit
Sub 宏1()
Dim arr1(1 To 10, 1 To 1) '這就定義形狀和A1:A10相同的空數組
Dim arr2() '這里不指定大小，下面從區域復制內容的時候能自動調整
arr2 = Range("a1:c6") '從區域家裡數組
Dim i&, j&
'下面的循環把數組 arr2 裡面的男性姓名復制到 arr1 中
j = 0 'arr1中已經復制的數據
For i = 2 To UBound(arr2) '循環arr2的每一行
If arr2(i, 2) = "男" Then
j = j + 1
arr1(j, 1) = arr2(i, 1) '復制姓名
End If
Next i
'把數組arr1寫到工作表區域中
Range("e1").Resize(j, 1) = arr1
End Sub
❷ 關於excel vba的問題
答：抱歉，我開始誤解了你的意思，現在更改了代碼，它的功能是獲取選取區域與A列組合的區域，同樣適合選擇區域本身包含A列的情況。
SubGetRng()
DimrAsRange
DimtAsRange
DimComRngAsRange'最終取得的區域
IfNotIntersect(Selection,Range("A:A"))IsNothingThen
SetComRng=Selection
Else
SetComRng=Union(Range("A"&Selection.Row).Resize(Selection.Rows.Count,1),Selection)
EndIf
EndSub
往下部分，你可以 Union(t, r) 替換為 ComRng。
❸ VBA選定區域的內容如何讀入數組
1 動態數組實現
定義一個自定義類型
type ExcelRows
colnum () as integer '當前第幾列
colValue() as string '當前列的值
end type
2. ActiveWorkbook.Worksheets(i).UsedRange 可以獲得選定的區域對象
然後取得選定區域的列數iC和行數iR
dim rangedata(ir) as ExcelRows
for i=0 to ic-1
redim rangedata(i).colnum(ic)
redim rangedata(i).colvalue(ic)
next
3 . 把數據寫入上邊聲明的rangedata數組
❹ Excel如何讀取指定區域內非空單元格數據及其行列號到另一個工作表中
Sub 統計()
Dim st1 As Worksheet, st2 As Worksheet
Dim Rng As Range, Rg As Range
Dim arr()
Dim i
Set st1 = Sheets("sheet1")
Set st2 = Sheets("sheet2")
Set Rng = st1.Range("b2:e4")
ReDim arr(1 To Rng.Count, 1 To 2)
i = 1
For Each Rg In Rng
If Rg <> "" Then
arr(i, 1) = st1.Cells(Rg.Row, 1) & st1.Cells(1, Rg.Column)
arr(i, 2) = Rg
i = i + 1
End If
Next
st2.Range("a1").Resize(UBound(arr), 2) = arr
End Sub
❺ 我想在excel使用vb復制某一區域內非空數據，如果是空的跳過
試試我的代碼
Private Sub Command1_Click()
Dim xlApp As New Excel.Application
Dim xlBook As New Excel.Workbook
Dim xlSheet As New Excel.Worksheet
Set xlBook = xlApp.Workbooks.Open(App.Path & "\1.xlsx")
xlApp.Visible = True
Set xlSheet = xlBook.Sheets("Sheet1")
With xlSheet
Dim n As Integer
Dim mycell As Range
n = 1
For Each mycell In .Range("A1:E15")
If mycell <> "" And mycell.Interior.Color = vbYellow Then
mycell.Copy .Cells(n, 8)
n = n + 1
End If
Next mycell
End With
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
❻ excel學習
問我啊,呵呵...
VBA語言基礎
第一節 標識符
一．定義
標識符是一種標識變數、常量、過程、函數、類等語言構成單位的符號，利用它可以完成對變數、常量、過程、函數、類等的引用。
二．命名規則
1） 字母打頭，由字母、數字和下劃線組成，如 A987b_23Abc
2） 字元長度小於40，（Excel2002以上中文版等，可以用漢字且長度可達254個字元）
3） 不能與VB保留字重名，如public, private, dim, goto, next, with, integer, single等
第二節 運算符
定義：運算符是代表VB某種運算功能的符號。
1）賦值運算符 =
2）數學運算符 &、+ (字元連接符)、+(加)、-（減）、Mod（取余）、\（整除）、*（乘）、/（除）、-（負號）、^（指數）
3）邏輯運算符Not（非）、And（與）、Or（或）、Xor（異或）、Eqv（相等）、Imp（隱含）
4）關系運算符 = （相同）、<>（不等）、>（大於）、<（小於）、>=（不小於）、<=（不大於）、Like、Is
5）位運算符 Not（邏輯非）、And（邏輯與）、Or（邏輯或）、Xor（邏輯異或）、Eqv（邏輯等）、Imp（隱含）
第三節 數據類型
VBA共有12種數據類型，具體見下表，此外用戶還可以根據以下類型用Type自定義數據類型。
數據類型 類型標識符 位元組
字元串型 String $ 字元長度(0-65400)
位元組型 Byte 無 1
布爾型 Boolean 無 2
整數型 Integer % 2
長整數型 Long & 4
單精度型 Single ! 4
雙精度型 Double # 8
日期型 Date 無 8 公元100/1/1-9999/12/31
貨幣型 Currency @ 8
小數點型 Decimal 無 14
變體型 Variant 無 以上任意類型，可變
對象型 Object 無 4
第四節 變數與常量
1）VBA允許使用未定義的變數，默認是變體變數。
2）在模塊通用說明部份，加入 Option Explicit 語句可以強迫用戶進行變數定義。
3）變數定義語句及變數作用域
Dim 變數 as 類型 '定義為局部變數，如 Dim xyz as integer
Private 變數 as 類型 '定義為私有變數，如 Private xyz as byte
Public 變數 as 類型 '定義為公有變數，如 Public xyz as single
Global 變數 as 類型 '定義為全局變數，如 Globlal xyz as date
Static 變數 as 類型 '定義為靜態變數，如 Static xyz as double
一般變數作用域的原則是，那部份定義就在那部份起作用，模塊中定義則在該模塊那作用。
4）常量為變數的一種特例，用Const定義，且定義時賦值，程序中不能改變值，作用域也如同變數作用域。如下定義：Const Pi=3.1415926 as single
第五節 數組
數組是包含相同數據類型的一組變數的集合，對數組中的單個變數引用通過數組索引下標進行。在內存中表現為一個連續的內存塊，必須用Global或Dim語句來定義。定義規則如下：
Dim 數組名([lower to ]upper [, [lower to ]upper, ….]) as type ;Lower預設值為0。二維數組是按行列排列，如XYZ(行，列)。
除了以上固定數組外，VBA還有一種功能強大的動態數組，定義時無大小維數聲明；在程序中再利用Redim語句來重新改變數組大小，原來數組內容可以通過加preserve關鍵字來保留。如下例：
Dim array1() as double : Redim array1(5) : array1(3)=250 : Redim preserve array1(5,10)
第六節 注釋和賦值語句
1）注釋語句是用來說明程序中某些語句的功能和作用；VBA中有兩種方法標識為注釋語句。
ü 單引號 』 ;如：』定義全局變數；可以位於別的語句之尾，也可單獨一行
ü Rem ;如：Rem定義全局變數；只能單獨一行
2）賦值語句是進行對變數或對象屬性賦值的語句，採用賦值號 =，如X=123：Form1.caption=」我的窗口」
對對象的賦值採用：set myobject=object 或 myobject:=object
第七節 書寫規范
1）VBA不區分標識符的字母大小寫，一律認為是小寫字母；
2）一行可以書寫多條語句，各語句之間以冒號 : 分開；
3）一條語句可以多行書寫，以空格加下劃線 _ 來標識下行為續行；
4）標識符最好能簡潔明了，不造成歧義。
第八節 判斷語句
1）If…Then…Else語句
If condition Then [statements][Else elsestatements]
如1：If A>B And C<D Then A=B+2 Else A=C+2
如2：If x>250 Then x=x-100
或者，可以使用塊形式的語法：
If condition Then
[statements]
[ElseIf condition-n Then
[elseifstatements] ...
[Else
[elsestatements]]
End If
如1:
If Number < 10 Then
Digits = 1
ElseIf Number < 100 Then
Digits = 2
Else
Digits = 3
End If
2）Select Case…Case…End Case語句
如1：
Select Case Pid
Case 「A101」
Price=200
Case 「A102」
Price=300
……
Case Else
Price=900
End Case
3）Choose 函數
choose(index, choce-1,choice-2,…,choice-n)，可以用來選擇自變數串列中的一個值，並將其返回，index 必要參數，數值表達式或欄位，它的運算結果是一個數值，且界於 1 和可選擇的項目數之間。choice 必要參數，Variant表達式，包含可選擇項目的其中之一。如：
GetChoice = Choose(Ind, "Speedy", "United", "Federal")
4）Switch函數
Switch(expr-1, value-1[, expr-2, value-2 _ [, expr-n,value-n]])
switch函數和Choose函數類似，但它是以兩個一組的方式返回所要的值，在串列中，最先為TRUE的值會被返回。 expr 必要參數，要加以計算的 Variant 表達式。value 必要參數。如果相關的表達式為 True，則返回此部分的數值或表達式，沒有一個表達式為 True，Switch 會返回一個 Null值。
第九節 循環語句
1）For Next語句 以指定次數來重復執行一組語句
For counter = start To end [Step step] ' step 預設值為1
[statements]
[Exit For]
[statements]
Next [counter]
如1：
For Words = 10 To 1 Step -1 ' 建立 10 次循環
For Chars = 0 To 9 ' 建立 10 次循環
MyString = MyString & Chars ' 將數字添加到字元串中
Next Chars ' Increment counter
MyString = MyString & " " ' 添加一個空格
Next Words
2）For Each…Next語句 主要功能是對一個數組或集合對象進行，讓所有元素重復執行一次語句
For Each element In group
Statements
[Exit for]
Statements
Next [element]
如1：
For Each rang2 In range1
With range2.interior
.colorindex=6
.pattern=xlSolid
End with
Next
這上面一例中用到了 With…End With 語句，目的是省去對象多次調用，加快速度；語法為：
With object
[statements]
End With
3）Do…loop語句 在條件為true時，重復執行區塊命令
Do {while |until} condition ' while 為當型循環，until為直到型循環，顧名思義，不多說啦
Statements
Exit do
Statements
Loop
或者使用下面語法
Do ' 先do 再判斷，即不論如何先干一次再說
Statements
Exit do
Statements
Loop {while |until} condition
第十節 其他類語句和錯誤語句處理
一．其他循環語句
結構化程序使用以上判斷和循環語句已經足夠，建議不要輕易使用下面的語句，雖然VBA還支持。
1) Goto line 該語句為跳轉到line語句行
2) On expression gosub destinatioinlist 或者 on expression goto destinationlist 語句為根據 exprssion表達式值來跳轉到所要的行號或行標記
3) Gosub line…line…Return語句， Return 返回到 Gosub line行，如下例：
Sub gosubtry()
Dim num
Num=inputbox(「輸入一個數字，此值將會被判斷循環」)
If num>0 then Gosub Routine1 ：Debug.print num：Exit sub
Routine1:
Num=num/5
Return
End sub
4) while…wend語句，只要條件為TRUE，循環就執行，這是以前VB老語法保留下來的，如下例：
while condition 『while I<50
[statements] 『I=I+1
wend 『Wend
二．錯誤語句處理
執行階段有時會有錯誤的情況發生，利用On Error語句來處理錯誤，啟動一個錯誤的處理程序。語法如下：
On Error Goto Line 『當錯誤發生時，會立刻轉移到line行去
On Error Resume Next 『當錯誤發生時，會立刻轉移到發生錯誤的下一行去
On Erro Goto 0 『當錯誤發生時，會立刻停止過程中任何錯誤處理過程
第十一節 過程和函數
過程是構成程序的一個模塊，往往用來完成一個相對獨立的功能。過程可以使程序更清晰、更具結構性。VBA具有四種過程：Sub 過程、Function函數、Property屬性過程和Event事件過程。
一．Sub過程
Sub 過程的參數有兩種傳遞方式：按值傳遞(ByVal)和按地址傳遞(ByRef)。如下例：
Sub password (ByVal x as integer, ByRef y as integer)
If y=100 then y=x+y else y=x-y
x=x+100
End sub
Sub call_password ()
Dim x1 as integer
Dim y1 as integer
x1=12
y1=100
Call password (x1,y1) 『調用過程方式：1. Call 過程名(參數1, 參數2…) ; 2. 過程名 參數1, 參數2…
debug.print x1,y1 『結果是12、112，y1按地址傳遞改變了值，而x1按值傳遞，未改變原值
End sub
二．Function函數
函數實際是實現一種映射，它通過一定的映射規則，完成運算並返回結果。參數傳遞也兩種：按值傳遞(ByVal)和按地址傳遞(ByRef)。如下例：
Function password(ByVal x as integer, byref y as integer) as boolean
If y=100 then y=x+y else y=x-y
x=x+100
if y=150 then password=true else password=false
End Function
Sub call_password ()
Dim x1 as integer
Dim y1 as integer
x1=12
y1=100
if password then 『調用函數：1. 作為一個表達式放在=右端 ; 2. 作為參數使用
debug.print x1
end if
End sub
三．Property屬性過程和Event事件過程
這是VB在對象功能上添加的兩個過程，與對象特徵密切相關，也是VBA比較重要組成，技術比較復雜，可以參考相關書籍。
第十二節內部函數
在VBA程序語言中有許多內置函數，可以幫助程序代碼設計和減少代碼的編寫工作。
一．測試函數
IsNumeric(x) 『是否為數字, 返回Boolean結果，True or False
IsDate(x) 『是否是日期, 返回Boolean結果，True or False
IsEmpty（x） 『是否為Empty, 返回Boolean結果，True or False
IsArray(x) 『指出變數是否為一個數組。
IsError(expression) 『指出表達式是否為一個錯誤值
IsNull(expression) 『指出表達式是否不包含任何有效數據 (Null)。
IsObject(identifier) 『指出標識符是否表示對象變數
二．數學函數
Sin(X)、Cos(X)、Tan(X)、Atan(x) 三角函數，單位為弧度
Log(x) 返回x的自然對數
Exp(x)返回 ex
Abs(x) 返回絕對值
Int(number)、Fix(number) 都返回參數的整數部分，區別：Int 將 -8.4 轉換成 -9，而 Fix 將-8.4 轉換成 -8
Sgn(number) 返回一個 Variant (Integer)，指出參數的正負號
Sqr(number) 返回一個 Double，指定參數的平方根
VarType(varname) 返回一個 Integer，指出變數的子類型
Rnd（x）返回0-1之間的單精度數據，x為隨機種子
三．字元串函數
Trim(string) 去掉string左右兩端空白
Ltrim(string) 去掉string左端空白
Rtrim(string) 去掉string右端空白
Len(string) 計算string長度
Left(string, x) 取string左段x個字元組成的字元串
Right(string, x) 取string右段x個字元組成的字元串
Mid(string, start,x) 取string從start位開始的x個字元組成的字元串
Ucase(string) 轉換為大寫
Lcase(string) 轉換為小寫
Space(x) 返回x個空白的字元串
Asc(string) 返回一個 integer，代表字元串中首字母的字元代碼
Chr(charcode) 返回 string，其中包含有與指定的字元代碼相關的字元
四．轉換函數
CBool(expression) 轉換為Boolean型
CByte(expression) 轉換為Byte型
CCur(expression) 轉換為Currency型
CDate(expression) 轉換為Date型
CDbl(expression) 轉換為Double型
CDec(expression) 轉換為Decemal型
CInt(expression) 轉換為Integer型
CLng(expression) 轉換為Long型
CSng(expression) 轉換為Single型
CStr(expression) 轉換為String型
CVar(expression) 轉換為Variant型
Val(string) 轉換為數據型
Str(number) 轉換為String
五．時間函數
Now 返回一個 Variant (Date)，根據計算機系統設置的日期和時間來指定日期和時間。
Date 返回包含系統日期的 Variant (Date)。
Time 返回一個指明當前系統時間的 Variant (Date)。
Timer 返回一個 Single，代表從午夜開始到現在經過的秒數。
TimeSerial(hour, minute, second) 返回一個 Variant (Date)，包含具有具體時、分、秒的時間。
DateDiff(interval, date1, date2[, firstdayofweek[, firstweekofyear]]) 返回 Variant (Long) 的值，表示兩個指定日期間的時間間隔數目
Second(time) 返回一個 Variant (Integer)，其值為 0 到 59 之間的整數，表示一分鍾之中的某個秒
Minute(time) 返回一個 Variant (Integer)，其值為 0 到 59 之間的整數，表示一小時中的某分鍾
Hour(time) 返回一個 Variant (Integer)，其值為 0 到 23 之間的整數，表示一天之中的某一鍾點
Day(date) 返回一個 Variant (Integer)，其值為 1 到 31 之間的整數，表示一個月中的某一日
Month(date) 返回一個 Variant (Integer)，其值為 1 到 12 之間的整數，表示一年中的某月
Year(date) 返回 Variant (Integer)，包含表示年份的整數。
Weekday(date, [firstdayofweek]) 返回一個 Variant (Integer)，包含一個整數，代表某個日期是星期幾
第十三節 文件操作
1） 文件
Dir[(pathname[, attributes])] ；pathname 可選參數，用來指定文件名的字元串表達式，可能包含目錄或文件夾、以及驅動器。如果沒有找到 pathname，則會返回零長度字元串 (""); attributes 可選參數。常數或數值表達式，其總和用來指定文件屬性。如果省略，則會返回匹配 pathname 但不包含屬性的文件。
2） 刪除
Kill pathname 從磁碟中刪除文件, pathname 參數是用來指定一個文件名
RmDir pathname 從磁碟中刪除刪除目錄，pathname 參數是用來指定一個文件夾
3） 打開
Open pathname For mode [Access access] [lock] As [#]filenumber [Len=reclength] 能夠對文件輸入/輸出 (I/O)。
pathname 必要。字元串表達式，指定文件名，該文件名可能還包括目錄、文件夾及驅動器。
mode 必要。關鍵字，指定文件方式，有 Append、Binary、Input、Output、或 Random 方式。如果未指定方式，則以 Random 訪問方式打開文件。
access 可選。關鍵字，說明打開的文件可以進行的操作，有 Read、Write、或 Read Write 操作。
lock 可選。關鍵字，說明限定於其它進程打開的文件的操作，有 Shared、Lock Read、Lock Write、和 Lock Read Write 操作。
filenumber 必要。一個有效的文件號，范圍在 1 到 511 之間。使用 FreeFile 函數可得到下一個可用的文件號。 reclength 可選。小於或等於 32，767（位元組）的一個數。對於用隨機訪問方式打開的文件，該值就是記錄長度。對於順序文件，該值就是緩沖字元數。
說明 對文件做任何 I/O 操作之前都必須先打開文件。Open 語句分配一個緩沖區供文件進行 I/O 之用，並決定緩沖區所使用的訪問方式。如果 pathname 指定的文件不存在，那麼，在用 Append、Binary、Output、或 Random 方式打開文件時，可以建立這一文件。如果文件已由其它進程打開，而且不允許指定的訪問類型，則 Open 操作失敗，而且會有錯誤發生。如果 mode 是 Binary 方式，則 Len 子句會被忽略掉。
重要 在 Binary、Input 和 Random 方式下可以用不同的文件號打開同一文件，而不必先將該文件關閉。在 Append 和 Output 方式下，如果要用不同的文件號打開同一文件，則必須在打開文件之前先關閉該文件。
4） 讀入
Input #filenumber, varlist 從已打開的順序文件中讀出數據並將數據指定給變數
Get [#]filenumber, [recnumber], varname將一個已打開的磁碟文件讀入一個變數之中。
5） 寫入
Write #filenumber, [outputlist] 將數據寫入順序文件
Print #filenumber, [outputlist] 將格式化顯示的數據寫入順序文件中
Put [#]filenumber, [recnumber], varname 將一個變數的數據寫入磁碟文件中。
6） 關閉
Close [filenumberlist] 關閉 Open 語句所打開的輸入/輸出 (I/O) 文件
注意 如果今後想用 Input # 語句讀出文件的數據，就要用 Write # 語句而不用 Print # 語句將數據寫入文件。因為在使用 Write # 時，將數據域分界就可確保每個數據域的完整性，因此可用 Input # 再將數據讀出來。使用 Write # 還能確保任何地區的數據都被正確讀出。Write 與 Print # 語句不同，當要將數據寫入文件時，Write # 語句會在項目和用來標記字元串的引號之間插入逗號。Write # 語句在將 outputlist 中的最後一個字元寫入文件後會插入一個新行字元，即回車換行符，(Chr(13) + Chr(10))。
7） 其他文件函數
LOF(filenumber) 返回一個 Long，表示用 Open 語句打開的文件的大小，該大小以位元組為單位。
EOF(filenumber) 返回一個 Integer，它包含 Boolean 值 True，表明已經到達為 Random 或順序 Input 打開的文件的結尾。
Loc(filenumber) 返回一個 Long，在已打開的文件中指定當前讀/寫位置
Seek(filenumber) 返回一個 Long，在 Open 語句打開的文件中指定當前的讀/寫位置
❼ MAPINFO批量統計各各區域裡面的點的數量或者線的長度
樣例數據已經發到你郵箱
Include "MAPBASIC.DEF"
open window message
Dim sAppPath,AreaName as String
Dim poiNum,LineNum As Integer
Dim myobj as Object
sAppPath=ApplicationDirectory$()
Open Table sAppPath+"Area.tab" as tab0''''請將文件名修改為你自己的區域文件名
Open Table sAppPath+"poi.tab" as tabP''''請將文件名修改為你自己的點文件名
open file sAppPath+"PNum.txt" for output as #1
Fetch First From tab0
Do While Not EOT(tab0)
myobj=tab0.obj
AreaName=tab0.Name'''tab0.Name需要改成實際區域表中的欄位的名字
select * from tabP where obj within myobj into temp
poiNum=tableinfo(temp,TAB_INFO_NROWS)
print #1,AreaName+":"+poiNum
Fetch Next From tab0
loop
close file #1
close all
note"OK"
❽ 程序實現
（一）實現思路
要實現土壤環境質量評價，首先要整理好評價數據，主要包括表層土壤有機污染物分析數據圖層、表層土壤地球化學全量分析數據圖層及表層土壤采樣數據圖層3個，統一格式和投影，並存放在資料庫中；用戶可根據許可權自動載入數據，並設置參數（如區塊顏色、評價指標、評價因子、模型庫等）直接進行評價，評價的結果可用報表或色塊圖輸出，關鍵在於模型庫的建立，具體按如下流程建立。
（1）「一票否決法」評價模塊
第一步，首先連接SQL Server資料庫，載入3個數據圖層，分別是表層土壤有機污染物分析數據圖層、表層土壤地球化學全量分析數據圖層及表層土壤采樣數據圖層。
第二步，遍歷表層土壤地球化學全量分析數據點，讀取pH、Cd、Hg、As、Cu、Pb、Cr、Zn、Ni欄位對應的值，先判斷該點的pH值區間范圍，根據此pH 值范圍判斷Cd、Hg、Pb、Zn、Ni元素含量是否超標，如果超標則表示該評價單元不合格，否則從表層土壤采樣數據圖層中讀取該點的4個采樣點的屬性欄位（「土地利用」）的值，如果4個采樣點的土地利用情況均為13（水澆地），則As、Cu、Cr 3個重金屬元素使用旱地的標准，再做是否超標的判斷，如果沒有超標則轉用下一步再做判斷。
第三步，根據該點的位置讀取表層土壤有機污染物分析數據圖層中相應的土壤有機污染物分析測試數據，判斷pH值區間范圍確定DDT和六六六的標准值，最後得出該點是否超標。
（2）單元素污染指數評價模塊
第一步，首先連接SQL Server資料庫，載入3個數據圖層，分別是表層土壤有機污染物分析數據圖層、表層土壤地球化學全量分析數據圖層及表層土壤采樣數據圖層。
第二步，獲取要進行評價的評價因子（如Hg）。
第三步，遍歷表層土壤地球化學全量分析數據點，分別讀取pH、Hg欄位對應的值，先判斷某點的pH值區間范圍，根據此pH值范圍判斷Hg元素的評價標准值（SHg），當然也可以區域背景平均值、平均值加2（3）倍標准差為評價標准，將該點的實測值與評價標准值（SHg）相除，即為該Hg元素的污染指數。
如果選取的是As、Cu、Cr 3個元素，則還要進一步根據表層土壤采樣數據圖層中的「土地利用」欄位值來判斷元素的評價標准值（S）。
如果選取的是DDT和六六六2個指標，則要遍歷表層土壤有機污染物分析數據點，讀取pH、DDT（或六六六）的欄位值，根據其pH值區間范圍確定DDT（或六六六）的標准值，同樣該點的實測值與評價標准值（S）相除，即為該DDT（或六六六）的污染指數。
第四步，根據單元素污染指數值分等定級土壤質量，一般（默認）採用如下標准：
單因子污染指數＜1，為非污染區；
單因子污染指數介於1～2之間，為輕污染；
單因子污染指數介於2～3之間，為中度污染；
單因子污染指數大於3，為重度污染。
（3）內梅羅（Nemrow）綜合污染指數評價模塊
第一步，首先連接SQL Server資料庫，載入3個數據圖層，分別是表層土壤有機污染物分析數據圖層、表層土壤地球化學全量分析數據圖層及表層土壤采樣數據圖層。
第二步，遍歷表層土壤有機污染物分析數據點，按照上述的單元素污染指數評價模塊分別計算DDT、六六六的污染指數值。
第三步，遍歷表層土壤地球化學全量分析數據點，按照上述的單元素污染指數評價模塊分別計算Cd、Hg、As、Cu、Pb、Cr、Zn、Ni的污染指數值。同時將表層土壤有機污染物分析數據點所控制的范圍（64km2）與表層土壤地球化學全量分析數據點做布爾運算，計算DDT、六六六、Cd、Hg、As、Cu、Pb、Cr、Zn、Ni的污染指數平均值和最大值。
第四步，根據內梅羅公式，計算每個評價單元（4km2）的綜合污染指數值。
第五步，根據綜合污染指數值分等定級土壤質量，默認可參考農業部農田土壤環境質量監測技術規范（NY/T 395—2000）（表7-4）。
表7-4 農田土壤環境質量分級標准
（二）關鍵代碼
Option Explicit
Option Compare Text
Private tpjstr As String＂評價類型
Private Const bzdict ＝＂土壤環境質量標准值＂＇土壤環境質量標准值
Private m_curpic As PictureBox＇當前的顏色框
Public m_map As MapObjects2.map＇傳入的地圖控制項
Private m_lyr As MapObjects2.maplayer＇評價的圖層
Public m_Is單 As Boolean＇是否是單因子評價
＇*************評價子過程**********************************************
Private Sub cmd評價_Click（）
Dim OldPrj As Object
On Error GoTo ERR
Dim t元素err As Long
Set OldPrj＝m_map.CoordinateSystem
GetDefPrj 120.5，m_map＇投影到浙江預設投影
Dim Tscale As Double＂＂載入數據單位與評價標准單位之間倍率
Dim tpolycols As Collection
Dim i As Long
Dim t元素污染 As C元素含量
Dim t元素 As String
Dim tlyr As MapObjects2.maplayer
Dim tmrd As MapObjects2.RecordSet
Dim t元素cols As Collection
Dim j As Long
Dim t評價目標 As String
If m_Is單 Then
t評價目標 ＝＂重金屬單因子污染評價＂
Else
t評價目標 ＝＂重金屬綜合污染評價＂
End If
Dim dirname As String
dirname＝m_配置.GetKey配置（m_配置文件，＂臨時路徑＂）＇獲得評價輸出路徑
Set tlyr＝CreateshpByName（m_map，dirname，t評價目標）＇創建評價圖層
If tlyr Is Nothing Then Exit Sub
Set t元素cols＝get元素cols
Set tpolycols＝Get評價單元（m_map，m_lyr.name，1000）＇獲得評價單元集合
Set tmrd＝tlyr.Records
tmrd.AutoFlush＝False＂防止每次修改操作自動引發對數據文件的寫入操作
Dim t污染 As Single＂污染指數
Dim tI和 As Single＂污染指數的總和
Dim MaxI As Single＂污染指數的最大值
Dim newshp As MapObjects2.Polygon
Dim ttdlx As String＂土壤質量等級
MaxI＝0
Dim tprg As New CProgress
For i＝1 To tpolycols.count
tprg.Value＝100*i/tpolycols.count＇設置進度
Set newshp＝UnProjected（m_map，m_lyr，tpolycols（i））
If m_Is單 Then＇單因子評價
Tscale＝getScale（cmb元素）
Set t元素污染＝get單因子污染指數（tpolycols（i），cmb元素，Tscale）
If Not t元素污染 Is Nothing Then
校檢數據，並給出錯原因.
代碼略
tmrd.AddNew
tmrd.Fields（＂shape＂）.Value＝newshp
tmrd.Fields（＂元素名稱＂）.Value＝t元素污染.元素名稱
t污染＝t元素污染.污染指數
ttdlx ＝＂＂
If t污染＜T指標（0）Then＂根據指標定級定色，T指標（）為單因子分級標准值
ttdlx＝Labcolor（0）.Tag
ElseIf t污染＞＝T指標（0）And t污染 ＜ T指標（1）Then
ttdlx＝Labcolor（1）.Tag
ElseIf t污染＞＝T指標（1）And t污染 ＜ T指標（2）Then
ttdlx＝Labcolor（2）.Tag
ElseIf t污染＞＝T指標（2）Then
ttdlx＝Labcolor（3）.Tag
End If
If ttdlx ＜＞＂＂Then
ttdlx＝Mid（ttdlx，2）
End If
tmrd.Fields（＂土壤質量＂）.Value＝ttdlx＂＂評價結果寫入評價圖層文件的屬性表
tmrd.Fields（＂污染指數＂）.Value＝t污染
tmrd.Fields（＂實測值＂）.Value＝t元素污染.實測值
tmrd.Fields（＂背景值＂）.Value＝t元素污染.背景值
tmrd.Update
End If
Else＇綜合評價
MaxI＝0
tI和＝0
For j＝1 Tot元素cols.count
Tscale＝getScale（t元素cols（j））
Set t元素污染＝get單因子污染指數（tpolycols（i），t元素cols（j），Tscale）
If Not t元素污染 Is Nothing Then
tI和＝tI和 + t元素污染.污染指數
If t元素污染.污染指數＞MaxI Then
MaxI＝t元素污染.污染指數＂＂計算所有該點元素污染指數的最大值
End If
End If
Next
t污染 ＝（（tI和/t元素cols.count）＾2 + MaxI ＾2）/2＂＂內梅羅公式
t污染＝Sqr（t污染）＂根據內梅羅公式計算綜合污染指數
tmrd.AddNew
tmrd.Fields（＂shape＂）.Value＝newshp
If t污染＜T指標（4）Then＂根據指標定級定色，T指標（）的值為綜合分級標准
tmrd.Fields（＂土壤質量＂）.Value＝Labcolor（4）.Tag
ElseIf t污染＞＝T指標（4）And t污染 ＜ T指標（5）Then
tmrd.Fields（＂土壤質量＂）.Value＝Labcolor（5）.Tag
ElseIf t污染＞＝T指標（5）And t污染 ＜ T指標（6）Then
tmrd.Fields（＂土壤質量＂）.Value＝Labcolor（6）.Tag
ElseIf t污染＞＝T指標（6）And t污染 ＜ T指標（7）Then
tmrd.Fields（＂土壤質量＂）.Value＝Labcolor（7）.Tag
ElseIf t污染＞＝T指標（7）Then
tmrd.Fields（＂土地類型＂）.Value＝Labcolor（8）.Tag
End If
tmrd.Fields（＂污染指數＂）.Value＝t污染ˊˊˊ評價結果寫入評價圖層文件的屬性表
tmrd.Update
End If
Next
Set tmrd＝Nothing
Set tlyr＝Nothing
Dim t評價目標Lyr As MapObjects2.maplayer
＇把評價結果加入到當前地圖
Set t評價目標Lyr＝addShapeFile（m_map，dirname ＆ t評價目標）
Set m_map.CoordinateSystem＝OldPrj
Set GClipPoly_prj＝Projected（m_map，GClipPoly_unprj）
If Not t評價目標Lyr Is Nothing Then
m_map.Layers.MoveToBottom GetLyrIndex（m_map，t評價目標Lyr.Tag）
End If
tpjstr＝dirname ＆ t評價目標
ERR：
Set tmrd＝Nothing
Set tlyr＝Nothing
Set t評價目標Lyr＝Nothing
End Sub
＇*************計算單因子污染指數******************************************
Private Function get單因子污染指數（tpoly As MapObjects2.Polygon，t元素名稱 As String，Tscale As Double）As C元素含量
Dim trd As MapObjects2.RecordSet
Dim tmpoly As MapObjects2.Polygon
Dim t元素 As String
t元素＝Get元素化學名稱（t元素名稱）翻譯元素化學名稱
Set tmpoly＝UnProjected（m_map，m_lyr，tpoly）＂＂＇返回投影前的圖形
Set trd＝m_lyr.SearchShape（tmpoly，moAreaIntersect，＂＂）＂＂＇返回符合空間查詢條件的記錄集
If returnRdEof（trd）Then＂＂返回查詢集是否建立.如假則表示沒建立，退出
Exit Function
End If
Dim t利用現狀 As String
Dim tpH值 As String
Dim t元素含量 As Single
判斷pH值區間范圍
t元素含量＝trd.Fields（＂PH＂）.Value
If t元素含量 ＜＝6.5 Then
tpH值 ＝＂＜6.5＂
Else
If t元素含量 ＜＝7.5 Then
tpH值 ＝＂6.5-7.5＂
Else
tpH值 ＝＂＞7.5＂
End If
End If
t利用現狀＝Get利用現狀（tpoly）＂＂返回土地利用現狀，水田或旱地
Dim t評價標准 As String
Dim thl As String
thl＝trd.Fields（t元素）.Value
If IsNumeric（thl）＝ False Then
Exit Function
End If
Set get單因子污染指數＝New C元素含量
t評價標准＝get評價標准（t元素名稱，tpH值，t利用現狀）＂獲取評價標准
Get單因子污染指數.元素名稱＝t元素名稱
Get單因子污染指數.背景值＝t評價標准
Get單因子污染指數.實測值＝thl*Tscale
Get單因子污染指數.污染指數＝thl/t評價標准*Tscale
End Function
＇***********獲取土地利用狀況**********************************************
Private Function Get利用現狀（tpt As MapObjects2.point）As String
Dim lyr As MapObjects2.maplayer
Dim trd As MapObjects2.RecordSet
Dim tQcstr As String
Dim 采樣Nums As Long，水田Nums As Long
Dim tmppoly As MapObjects2.Polygon
Dim tstr1 As String，tstr2 As String
If C_評價目標＝土壤環境質量標准值 Or C_評價目標＝綠色農產品產地評價 Then
Set lyr＝getlyr評價（m_map，Optlyr（0）.Caption）
If lyr.Records.Fields（＂cw＂）.Type＝moString Then
tstr1 ＝＂cw＝＇1＂＇
Else
tstr1 ＝＂cw＝1＂
End If
If lyr.Records.Fields（＂LYXZ＂）.Type＝moString Then
tstr2 ＝＂（LYXZ ＝＇11＇or LYXZ＝13）＂
Else
tstr2 ＝＂（LYXZ＝11 or LYXZ＝13）＂
End If
Dim tpoly As MapObjects2.Polygon
Dim tmppt As MapObjects2.point
Set tmppt＝Projected（m_map，tpt，lyr）
Set tpoly＝GetPolytByCentPt（tmppt，1000）
Set tmppoly＝UnProjected（m_map，lyr，tpoly）
Set trd＝lyr.SearchShape（tmppoly，moAreaIntersect，tstr1）
采樣Nums＝ReturnNums（trd）
Set trd＝lyr.SearchShape（tmppoly，moAreaIntersect，tstr1 +＂and＂+ tstr2）
水田Nums＝ReturnNums（trd）
If 采樣Nums＝0 Then
Get利用現狀 ＝＂旱地＂
Exit Function
End If
If 水田Nums/采樣Nums＞＝0.5 Then
Get利用現狀＝＂水田＂
Else
Get利用現狀 ＝＂旱地＂
End If
End If
End Function
（三）實例
選取「浙江省農業地質環境調查」項目中蕭山示範區1：5萬表層土壤單點樣測試分析數據、1：5萬表層土壤有機污染物分析數據圖層及1：5萬表層土壤采樣數據圖層作為示例數據。採用比較成熟的內梅羅綜合污染指數法，對蕭山示範區土壤環境質量現狀進行評價。通過土壤環境質量評價，劃分四級土壤（見圖版12），其中，Ⅰ級（安全區）占總面積的85.91%、Ⅱ級（警戒限區）佔9.73%、Ⅲ級（輕污染區）佔4.03%、Ⅳ級（中污染區）佔0.03%。Ⅰ類土壤集中分布於北塘河以北的廣大區域，這是蕭山最重要的土地資源分布區，在蕭山具舉足輕重的地位；Ⅱ類土壤集中分布於蕭山南部，分布比較零散，主要與人類活動有關；Ⅲ類土壤主要分布於蕭山城郊的新塘、來蘇與杜家一帶，與人為因素有關；Ⅳ類土壤主要分布在樓塔岩上一帶，影響其土壤環境質量的主要因素是礦化作用。
❾ 什麼是DIM協議
DIM是融合了區塊鏈、DNS、智能合約、電子郵件、即時通訊協議五大技術的新型技術。DIM真正做到了基於去中心化的即時通訊協議，並實現統一標識跨鏈賬戶地址。DIM使得跨平台通訊成為了可能，它重新定義了通訊，把互聯網鏈接直接升級到物聯網鏈接。
❿ 請問在EXCEL中如何通過VBA 鏈接圖片到指定的區域
Sub Insert() '插入圖片到指定單元格！
Dim a As Object
Sheet1.Pictures.Delete
Set a = Sheet1.Pictures.Insert("C:\Documents and Settings\Administrator\桌面\dscn123.jpg")
a.Top = [a1].Top
a.Height = [a1].Height + [a2].Height + [a3].Height + [a4].Height + [a5].Height
a.Left = [a1].Left
a.Width = [a1].Width + [b1].Width + [c1].Width + [d1].Width + [e1].Width
End Sub
以上代碼可以再sheet1中插入一張圖片，圖片大小剛好占滿a1：e5的范圍。