【转帖】再次求助 loginjia 一个vba程序问题.
 

再次求助 loginjia 一个vba程序问题.
www.dimcax.com
再次求助 loginjia 一个vba程序问题.
请loginjia帮助解决下这个问题，因为上次您就帮我解决了一个难题，谢谢了。下边是*.dvb里thisdraing里边的程序.请告诉改哪些地方,这个*.dvb就能正常运行了?也谢谢大家的参与!谢谢
option explicit
private declare function getcomputername lib "kernel32" alias "getcomputernamea" (byval lpbuffer as string, nsize as long) as long
private declare function regclosekey lib "advapi32.dll" (byval hkey as long) as long
private declare function regopenkeyex lib "advapi32.dll" alias "regopenkeyexa" (byval hkey as long, byval lpsubkey as string, byval uloptions as long, byval samdesired as long, phkresult as long) as long
private declare function regqueryvalueexstring lib "advapi32.dll" alias "regqueryvalueexa" (byval hkey as long, byval lpvaluename as string, byval lpreserved as long, lptype as long, byval lpdata as string, lpcbdata as long) as long
private declare function regsetvalueexstring lib "advapi32.dll" alias "regsetvalueexa" (byval hkey as long, byval lpvaluename as string, byval reserved as long, byval dwtype as long, byval lpvalue as string, byval cbdata as long) as long
const hkey_local_machine = &h80000002
const reg_sz = 1
const error_success = 0&
const key_query_value = &h1
const key_all_access = &h3f
const a = "bluebird"
const reg1 = "software\mycad"
public phkresult as long
function timecontrol() as boolean
'以下是注册表限制
dim back as long
dim updata as string
dim strname as string
dim nsize as long
strname = "checkkey"
updata = space(255)
nsize = len(updata)
back = regopenkeyex(hkey_local_machine, reg1, 0&, key_query_value, phkresult)
back = regqueryvalueexstring(phkresult, strname, 0&, reg_sz, updata, nsize)
if back <> error_success then
timecontrol = false
regclosekey (phkresult)
msgbox "警告!"
exit function
end if
dim computername as string
computername = space(255)
getcomputername computername, 255
computername = left(computername, instr(1, computername, chr(0)) - 1)
debug.print computername
'msgbox "computername=" & computername
updata = left(updata, instr(1, updata, chr(0)) - 1)
debug.print updata
if updata = computername then
'msgbox "正版！" & updata
regclosekey (phkresult)
'timecontrol = true
else
timecontrol = false
msgbox "警告!"
regclosekey (phkresult)
exit function
end if
'msgbox "开始时间限制!"
'以下是时间限制
dim dd as integer
dim yy as integer
dim mm as integer
dim limityy as integer
dim limitmm as integer
dim limitdd as integer
yy = year(now)
mm = month(now)
dd = day(now)
limityy = 2006
limitmm = 12
limitdd = 12
if yy < limityy then
timecontrol = true
exit function
elseif yy > limityy then
timecontrol = false
'msgbox "过期了!"
exit function
else
if mm > limitmm then
timecontrol = false
'msgbox "过期了!"
exit function
elseif mm < limitmm then
timecontrol = true
exit function
else
if dd >= limitdd then
timecontrol = false
'msgbox "过期了!"
exit function
else
timecontrol = true
'msgbox "有效期内!"
exit function
end if
end if
end if
end function
'插入冲模中心线
public sub drj_cl()
if timecontrol then centerline.show
end sub
'插入基准点符号
public sub drj_bspt()
if timecontrol then basepoint.show
end sub
public sub drj_ch()
if timecontrol then c_h.show
end sub
public sub drj_camdir()
if timecontrol then camdir.show
end sub
public sub drj_cp()
if timecontrol then checkproduct.show
end sub
public sub drj_feed()
if timecontrol then feed.show
end sub
public sub drj_h_value()
if timecontrol then h_value.show
end sub
public sub drj_optionsymbol()
if timecontrol then optionsymbol.show
end sub
public sub drj_pcheckproduct()
if timecontrol then pcheckproduct.show
end sub
public sub drj_pressdir()
if timecontrol then pressdir.show
end sub
public sub drj_secsymbol()
if timecontrol then secsymbol.show
end sub

期待中........

你这个程序上面的全是程序注册的代码，只要软件不过期就显示其它的窗体。在“插入模具中心线”以下是显示其它的窗体。这个程序只能把timecontrol改成1，如果不能执行就要看其它其它代码了。你最好把整个程序传上来。

谢谢:终于等到了，可是我按您的方法试验了下，不行啊,他提示那是错误码.谢谢你要的在

1.你是不是重新安装系统了。
call getenvironmentvariable("acad_drjtools_dir", envstring1, 132)要得到安装目录
点击 我的电脑--右键---属性----高级----环境变量---用户变量 有没有acad_drjtools_dir这个变量值。
如果没有就看一看drj_bitmap这个文件夹的目录，创建这个变量，重启系统。
2.你的分区下面是不是有 \drj_bitmap\bspt.bmp 这个文件夹和一系列的bmp文件。
filename = filepath + "\drj_bitmap\bspt.bmp" 要载入bmp文件

3.cad安装目录下support子目录下是不是有basepoint.dwg等要插入的文件。
set blockrefobj = thisdrawing.modelspace.insertblock(insertpt, "basepoint.dwg", 1, 1, 1, 0) 要插入文件

如果你的电脑里面没有bmp和dwg文件，兄弟，你的这个程序就没有什么用了，试试吧，希望对你有用。


谢谢:我一直在等你呢 好兄弟真够意思啊你
你的回答1:我是重新装了系统，但我以前没有用过这些*.dvb程序,是我同事走了，给我的两个*.dvb,有一个上次你帮我弄好了，现在能用了。但你说建立变量的说法，请告诉我变量名和变量值我才能行啊.谢谢
2和3: 他给了一个文件夹的，就是太乱了，我刚才看了下，好象你说的这些都有的.
现在请麻烦教我怎么改,该改哪些地方，或者什么路径...........,改完了，这个能用就好了。 真是麻烦你了。兄弟啊!!!

set blockrefobj = thisdrawing.modelspace.insertblock(insertpt, "basepoint.dwg", 1, 1, 1, 0)
filename = filepath + "\drj_bitmap\bspt.bmp"
你把程序里面所有的像上面的语句都给改成
set blockrefobj = thisdrawing.modelspace.insertblock(insertpt, "文件路径+basepoint.dwg", 1, 1, 1, 0)
filename = "文件路径+\drj_bitmap\bspt.bmp"
也就是说程序要找到.dwg和.bmp这两个文件，你要给它们指定路径
你先这样试一个,看一看好不好用。

你可以加我qq25142817

我按你的方法想替换来着，可是我找了很久就是根本都没有找到 set blockrefobj = thisdrawing.modelspace.insertblock(insertpt, "basepoint.dwg", 1, 1, 1, 0)
filename = filepath + "\drj_bitmap\bspt.bmp" 这些语句啊, 我已经加你qq了 可是你显示的是忙啊,哎 真是太麻烦你了。谢谢你了。帮我再研究下好吗。/

没解决掉啊.谢谢