ocr图片识别研究

dcl1214 · 发表于 2023-6-10 08:53:10

购买主题 已有 17 人购买 本主题需向作者支付 3 个明经币 才能浏览

edata · 发表于 2023-6-10 11:32:58

dhl 发表于 2023-6-10 10:14
我win10上找不到OCR.EXE

可以试试这个，https://github.com/zh-h/Windows.Media.Ocr.Cli

.net v4.5.1
WIN10版本要求
Build 10240, Build 10586, Build 14383, Build 15063, Build 16299, Build 17134, Build 17763, Build 18362, Build 19041, Build 20348, Build 22000, Build 22621

说明
===========================================================================================
Windows.Media.Ocr.Cli
Ocr 命令行工具，本地调用 UWP API Windows.Media.Ocr 支持多种语言识别。

使用
下载
https://github.com/zh-h/Windows.Media.Ocr.Cli/releases

命令行执行
PS C:\Tools>Windows.Media.Ocr.Cli.exe .\x.png
9·哪位科学家发现了电磁感应现象？
PS C:\Tools>Windows.Media.Ocr.Cli.exe -o .\res.txt .\x.png
-> 将内容输出到res.txt中
查看帮助
PS C:\Tools>Windows.Media.Ocr.Cli.exe -h
Usage: Windows.Media.Ocr.Cli.exe [options...] <image file path>
Example: Windows.Media.Ocr.Cli.exe -o c:\res.txt x.png
-l <language> Default:zh-Hans-CN Specify language to reconizing
-o <output_path> Output the resalut to a file, It should end with a file name, such as res.txt.
-s Show all supported languages
-h Show help like this
运行依赖
需要 Windows 10 系统，其他平台没有测试，理论上可以支持所有支持 UWP 的设备，包括 Xbox 甚至安装 Windows 10 IoT 的树莓派，不太了解 Xamarin 能不能引入 UWP 的 runtime，如果能引入 UWP 就可以用在 iOS 和 Android 平台。

树櫴希德 · 发表于 2024-5-12 16:35:07

；(setq qz (vl-filename-mktemp "ocr" (getvar "SAVEFILEPATH")) ) ;前缀(vl-filename-mktemp "ocr" (getenv "temp"))

临时文件放临时保存文件夹较为合适，WIN10某些C盘不能读入写出文件，很烦，(getvar "SAVEFILEPATH") 保存到D盘
OCR不认文件路径"\\",只是认识正斜杠于是又要替换 ljx-string-translate
OCR放在CAD安装目录，反正又不大，，不用写路径直接如：（command "shell" Windows.Media.Ocr.Cli.exe d:/temp/ocr004.png > d:/temp/ocr004.txt ）
Windows.Media.Ocr.Cli.exe要把断线文字线条加宽，不然不认识，空却，还经常认错字，像我一样近视，不要抱太大期望

;;;;函数名称: ljx-string-translate
;;;;调用格式: (ljx-string-translate newtx oldtx str)
;;;;参数说明: newtx ----- 要替换成的新字符
;;;; oldtx-要替换的旧字符
;;;; str 在str字符中替换
;;;;返回值: (ljx-string-translate "xx" "a" "123xxjkhxx") 返回""123ajkha""、
;;;; (ljx-string-translate "xx" "" "123jkh")返回"1213jkh"
;;;; newtx为""时相当于删除字符功能，非常好用
;;;;函数简介: 字符串替换函数，要替换的源字符与新字符长度可以不同，替换非常灵活好用
;;;;函数来源: 原创
;;;;函数作者: jixiangluo
;;;;适用版本: 不限
;;;;最后更新时 2019-08-03
;|(defun ljx-string-translate (newtx oldtx str / str1 i txz txy)
(setq str1 str)
(while (vl-string-search oldtx str1 )
(cond
((= oldtx str1)
(setq str newtx)
)
((= (vl-string-search oldtx str1) 0)
(setq i (+ (strlen oldtx) 1)
txy""
)
(repeat (- (strlen str1) (strlen oldtx))
(setq txy (strcat txy (substr str1 i 1))
i (1+ i)
)
);;;;repeat
(setq str (strcat newtx txy))
)
((= (vl-string-search oldtx str1) (- (strlen str1) (strlen oldtx) 1))
(setq i 1
txz ""
)
(repeat (- (strlen str1) (strlen oldtx))
(setq txz (strcat txz (substr str1 i 1))
i (1+ i)
)
)
(setq str (strcat txz newtx))
)
(T
(setq i 1
txz ""
)
(repeat (vl-string-search oldtx str1)
(setq txz (strcat txz (substr str1 i 1))
i (1+ i)
)
);;;;repeat
(setq i (+ i (strlen oldtx))
txy ""
)
(repeat (- (strlen str1) i -1)
(setq txy (strcat txy (substr str1 i 1))
i (1+ i)
)
);;;;repeat
(setq str (strcat txz newtx txy))
)
);;;;cond
(setq str1 str)
);;;;while
str1
);;;;defun|;
(defun ljx-string-translate (newtx oldtx str / str1 strL oldL txt tx1 tx2 n1)
(setq str1 str
strL (strlen str1)
oldL (strlen oldtx)
txt ""
)
(while (setq n1 (vl-string-search oldtx str1 ))
(setq tx1 (substr str1 1 n1)
tx2 (substr str1 (+ n1 1 oldL) (- strL (strlen tx1) oldL))
txt (strcat txt tx1 newtx)
)
(setq str1 tx2
strL (strlen str1)
)
)
(setq txt (strcat txt str1))
);;;;defun
(defun lst->ss (lst / SS X)
;图元转选择集
(if (and lst (setq lst (vl-remove nil lst))(setq
lst (VL-REMOVE-IF-NOT (FUNCTION (LAMBDA (A) (ENTGET A))) lst)
))
(progn
(setq ss (ssadd))
(last
(mapcar(function(lambda (x) (ssadd x ss)))lst)
)
)
)
SS
)
(defun $ocr-dwg$ (ss )
(setq qz (vl-filename-mktemp "ocr" (getvar "SAVEFILEPATH")) ) ;前缀(vl-filename-mktemp "ocr" (getenv "temp"))
(setq png-p (strcat qz ".png")) ;图片文件名
(setq txt-p (strcat qz ".txt")) ;txt文件名
;(setq ss (ssget ) ) ;提示用户框选pdf图元 SS在主函数中"_P"
(VL-CMDF "PNGOUT" png-p ss "") ;输出图片
(SETQ EXE-P (findfile "Windows.Media.Ocr.Cli.exe"))
(vl-cmdf "shell" (strcat "Windows.Media.Ocr.Cli.exe" " " (ljx-string-translate "/" "\\" png-p) " " " > " (ljx-string-translate "/" "\\" txt-p) ))
(setq i 0)
(setq go t)
(while (and go (< i 200000000)) ;防止ocr软件保存txt时间不够，这里给定循环时间
(if (setq f (vl-catch-all-apply 'open (list txt-p "r")))
;开启txt文件准备读取字串
(while
(setq str (vl-catch-all-apply 'read-line (list f)))
;逐行读取
(if str
(setq go nil)
) ;一旦读取到了字串就让while结束循环
(setq strs (cons str strs)) ;字串记录
)
)
(vl-catch-all-apply 'close (list f)) ;关闭文件
(setq i (1+ i))
)
(setq strs (vl-remove '"" strs)) ;删除空行
(setq strs (reverse strs)) ;颠倒过来
(and ss(setq ents(vl-remove-if(function listp)(mapcar (function cadr) (ssnamex SS)))));选择集转图元
(setq jbs(mapcar(function(lambda(a)(cdr(assoc 5(entget a)))))ents));获取句柄
(if ss(SETQ BOX (getbox SS NIL)))
(vl-catch-all-apply 'vl-file-delete (list png-p)) ;删除图片文件
(vl-catch-all-apply 'vl-file-delete (list txt-p)) ;删除txt文件
(setq ss nil)
(LIST (CONS "坐标" BOX) (cons "字串" strs)(cons "图元句柄" jbs));返回
)
(defun getbox (xzj QJBLM / i xdir
ydir zdir origin wcsOrg UcsFlag
matLst matrix revMat sel ent
obj minPt maxPt minLs maxLs
maxX maxY minX minY
Make-Rectange-getbox dxf $GetMatrix$
)
;;; ;诡异的填充
;(ENTMAKE (QUOTE ((0 . HATCH) (100 . AcDbEntity) (100 . AcDbHatch) (10 0.0 0.0 0.0) (210 0.0 0.0 1.0) (2 . SOLID) (70 . 1) (71 . 0) (91 . 1) (92 . 1) (93 . 1) (72 . 2) (10 3.67321e-006 -1.0 0.0) (40 . 1.0) (50 . 1.5708) (51 . 1.5708) (73 . 1) (97 . 0) (75 . 0) (76 . 1) (98 . 1) (10 97.2 305.1 0.0))))会导致外包围错误
;;先判断UCS是否与WCS相同。如是则取得UCS的X方向，
;;Y方向，Z方向，UCS原点及WCS的原点相对UCS的坐标点
;;然后得到UCS变换矩阵和到WCS的逆变换矩阵
;QJBLM 全局使用的变量名（字符串格式）,这个将作为全局变量名供很多地方调用
(defun Make-Rectange-getbox (PTT1 PTT2 QJBLM)
;;; ;构造矩形
;;; (IF (/= $EF-tzqy(vl-princ-to-string(list(list (car PTT1) (cadr PTT1))(list (car PTT2) (cadr PTT1))(list (car PTT2) (cadr PTT2))(list (car PTT1) (cadr PTT2)))))(ALERT "变了哦"))
(set (read QJBLM)
(vl-princ-to-string
(list (list (car PTT1) (cadr PTT1))
(list (car PTT2) (cadr PTT1))
(list (car PTT2) (cadr PTT2))
(list (car PTT1) (cadr PTT2))
)
) ;将坐标点赋值给QJBLM
)
;;; (TTEDIT (entlast) "zx-tzqy" (cons 1000 (vl-princ-to-string(list(list (car PTT1) (cadr PTT1))(list (car PTT2) (cadr PTT1))(list (car PTT2) (cadr PTT2))(list (car PTT1) (cadr PTT2))))) "del")
)
(defun $GetMatrix$ (lst org Revflag / mat i j)
(setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3)))
;初始化一个4X4的矩阵
(setq i 0)
(repeat 3
(vlax-safearray-put-element mat i 3 (nth i org)) ;平移变换
(setq j 0)
(repeat 3
(if RevFlag
(vlax-safearray-put-element mat i j (nth j (nth i lst)))
;角度逆变换
(vlax-safearray-put-element mat i j (nth i (nth j lst)))
;角度的变换
)
(setq j (1+ j))
)
(setq i (1+ i))
)
(vlax-safearray-put-element mat 3 3 1)
mat ;返回矩阵
)
(defun G:CrossProductor (vec1 vec2 / a b c d e f)
;;; ;两矢量的叉积
(setq a (car vec1))
(setq b (cadr vec1))
(setq c (caddr vec1))
(setq d (car vec2))
(setq e (cadr vec2))
(setq f (caddr vec2))
(list
(- (* b f) (* c e))
(- (* c d) (* a f))
(- (* a e) (* b d))
)
)
(if (and
xzj
(or (and (= (TYPE XZJ) 'VLA-OBJECT) (SETQ XZJ (LST->SS (LIST (vlax-vla-object->ename XZJ)))))
(and (= (TYPE XZJ) 'ENAME) (SETQ XZJ (LST->SS (LIST XZJ))))
;如果传递进来的是一个图元，就自动转换一下
(and (= (TYPE XZJ) 'list)
(= (TYPE (car XZJ)) 'ENAME)
(SETQ XZJ (LST->SS xzj))
) ;如果传递进来是一个图元列表ss，就自动转换选择集
t
)
(= (type xzj) 'pickset)
(or (and qjblm (= (type qjblm) 'str) (> (strlen qjblm) 1))
(not qjblm)
)
)
(progn
(setq UcsFlag (getvar "WORLDUCS"))
(if (= UcsFlag 0) ;UCS是否与WCS相同
(setq UcsFlag T ;设置标志位为true
xdir (getvar "UCSXDIR") ;X方向矢量
ydir (getvar "UCSYDIR") ;Y方向矢量
zdir (G:CrossProductor xdir ydir)
;X和Y的方向矢量的叉积
origin (getvar "UCSORG") ;原点
WcsOrg (trans '(0 0 0) 0 1) ;WCS的原点相对UCS的坐标
matLst (list xdir ydir zdir) ;旋转的变换矩阵表
matrix ($GetMatrix$ matLst origin nil)
;从WCS到UCS的变换矩阵
revMat ($GetMatrix$ matLst WcsOrg T) ;从UCS到WCS的变换矩阵
)
(setq UcsFlag nil) ;否则不予变换
)
;;在UCS下先变换物体到WCS下，取得每个物体的包围框，
;;求出包围框集合的最小XY，最大XY，并用矩形框画出来
;;然后把物体变换回到UCS，并把矩形也变换回去
(if (setq sel xzj)
;;选择物体
(progn
(setq i 0)
(setq minPt (vlax-make-safearray vlax-vbdouble '(0 . 2)))
;左下角点
(setq maxPt (vlax-make-safearray vlax-vbdouble '(0 . 2)))
;右上角点
(repeat (sslength sel)
(if (and (setq dxf nil
dxf (entget (setq ent (ssname sel i)))
) ;图元
(or (AND (WCMATCH (CDR (ASSOC 0 DXF)) "*TEXT")
(WCMATCH (CDR (ASSOC 1 DXF)) "[, ,,]")
;空格或者是空值“”
) ;如果一个空格文字的话
(and (= (cdr (assoc 0 dxf)) "HATCH")
(= (cdr (assoc 93 dxf)) 1)
) ;反正93等于1的时候不能创建填充，但是遇到诡异的填充，93等于1就可以创建，既然93在诡异的情况下可以创建，那就用93=1来排除它，诡异的填充在这里：;(ENTMAKE (QUOTE ((0 . HATCH) (100 . AcDbEntity) (100 . AcDbHatch) (10 0.0 0.0 0.0) (210 0.0 0.0 1.0) (2 . SOLID) (70 . 1) (71 . 0) (91 . 1) (92 . 1) (93 . 1) (72 . 2) (10 3.67321e-006 -1.0 0.0) (40 . 1.0) (50 . 1.5708) (51 . 1.5708) (73 . 1) (97 . 0) (75 . 0) (76 . 1) (98 . 1) (10 97.2 305.1 0.0))))
)
)
() ;以上条件成立以后，啥也不敢干呀
(PROGN
(setq obj (vlax-ename->vla-object ent)) ;obj对象
(and UcsFlag (vla-TransformBy obj revMat))
;反变换到WCS
;;; (vla-GetBoundingBox obj 'minpt 'maxpt)
(and (not (vl-catch-all-error-p
(vl-catch-all-apply
'vla-GetBoundingBox
(list obj 'minPt 'maxPt)
)
)
) ;得到包围框
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt))
(setq minLs (cons minPt minLs)) ;得到左下角点表
(setq maxLs (cons maxPt maxLs)) ;得到右上角点表
)
(and UcsFlag (vla-TransformBy obj matrix))
;变换回到UCS
)
)
(setq i (1+ i))
)
(and minLs
(setq minX (apply 'min (mapcar 'car minLs)))
;最小点集的最小X
(setq minY (apply 'min (mapcar 'cadr minLs)))
;最小点集的最小Y
)
(and maxLs
(setq maxX (apply 'max (mapcar 'car maxLs)))
;最大点集的最小X
(setq maxY (apply 'max (mapcar 'cadr maxLs)))
;最打点集的最小Y
)
(and QJBLM
(Make-Rectange-getbox
(list minX minY 0)
(list maxX maxY 0)
QJBLM
)
) ;构造边框
;;; (and
;;; UcsFlag ;如果UCS的话
;;; (vla-TransformBy
;;; (vlax-ename->vla-object (entlast))
;;; matrix ;变换边框到UCS
;;; )
;;; )
)
)
)
)
(IF (AND minX minY maxX maxY)
(list (list minX minY 0) (list maxX maxY 0))
)
)
(defun c:ocr123 (/ 1/2p 1/2p-n bl box box-new ent ents html jbs l obj result s sbjg ss str strs)
(setq sbjg ($ocr-dwg$ (ssget)))
(SETQ BOX(CDR(ASSOC "坐标" sbjg)))
(setq strs (cdr (assoc "字串" sbjg)))
(if strs
(progn
(setq jbs(cdr(assoc "图元句柄" sbjg)))
(setq ents(mapcar 'handent jbs))
(setq ss (ssadd))
(mapcar(function(lambda (x) (ssadd x ss)))ents)
(if ss(vl-cmdf "change" ss "" "P" "C" 1 ""))
(setq ss nil)
(setq s nil)
(while (setq str (car strs))
(if s
(setq s (strcat s "\n" str))
(setq s str)
)
(setq strs (cdr strs))
)
(setq str s)
(SETQ L(ABS(APPLY '-(MAPCAR 'CAR BOX))))
(SETQ L(* L 0.8))
(setq OBJ (vla-addmtext(vla-get-modelSpace(vla-get-ActiveDocument (vlax-get-acad-object)))(vlax-3d-point (list 0 0 0))(vlax-make-variant L 5)str))
(SETQ ENT(VLAX-VLA-OBJECT->ENAME OBJ))
(SETQ BOX-NEW(GETBOX ENT NIL))
(SETQ BL(/(ABS(distance(car BOX)(cadr box)))(ABS(distance(car BOX-NEW)(cadr BOX-NEW)))))
(setq 1/2p(mapcar(function(lambda(x y)(* (+ x y)0.5)))(car BOX)(cadr BOX)))
(setq 1/2p-n(mapcar(function(lambda(x y)(* (+ x y)0.5)))(car BOX-NEW)(cadr BOX-NEW)))
(vla-ScaleEntity OBJ(vlax-3D-point 1/2p-n)bl)
(vla-move obj (vlax-3d-point 1/2p-n) (vlax-3d-point 1/2p))
(setq html (vlax-create-object "htmlfile")
result (vlax-invoke
(vlax-get (vlax-get html 'ParentWindow)
'ClipBoardData
)
'setData
"Text"
str
)
)
(vlax-release-object html)
)
)
obj
)

;;;;函数名称:  ljx-string-translate 
;;;;调用格式:  (ljx-string-translate newtx oldtx str) 
;;;;参数说明:  newtx ----- 要替换成的新字符 
;;;;            oldtx-要替换的旧字符 
;;;;            str  在str字符中替换       
;;;;返回值:  (ljx-string-translate "xx" "a" "123xxjkhxx") 返回""123ajkha""、 
;;;;            (ljx-string-translate "xx" "" "123jkh")返回"1213jkh" 
;;;;            newtx为""时相当于删除字符功能，非常好用 
;;;;函数简介:  字符串替换函数，要替换的源字符与新字符长度可以不同，替换非常灵活好用             
;;;;函数来源:  原创 
;;;;函数作者:  jixiangluo 
;;;;适用版本:  不限 
;;;;最后更新时  2019-08-03 
 
;|(defun ljx-string-translate (newtx oldtx str / str1 i txz txy) 
  (setq str1 str) 
  (while (vl-string-search oldtx str1 ) 
    (cond 
      ((= oldtx str1) 
       (setq str newtx) 
      ) 
      ((= (vl-string-search oldtx str1) 0) 
       (setq i (+ (strlen oldtx) 1) 
       txy"" 
       ) 
       (repeat (- (strlen str1) (strlen oldtx)) 
   (setq txy (strcat txy (substr str1 i 1)) 
         i (1+ i) 
   ) 
       );;;;repeat 
       (setq str (strcat newtx txy)) 
      ) 
      ((= (vl-string-search oldtx str1) (- (strlen str1) (strlen oldtx) 1)) 
       (setq i 1 
       txz "" 
       ) 
       (repeat (- (strlen str1) (strlen oldtx)) 
   (setq txz (strcat txz (substr str1 i 1)) 
         i (1+ i) 
   ) 
       ) 
       (setq str (strcat txz newtx)) 
      ) 
      (T 
       (setq i 1 
             txz "" 
       ) 
       (repeat (vl-string-search oldtx str1) 
   (setq txz (strcat txz (substr str1 i 1)) 
         i (1+ i) 
   ) 
       );;;;repeat 
       (setq i (+ i (strlen oldtx)) 
       txy "" 
       ) 
       (repeat (- (strlen str1) i -1) 
   (setq txy (strcat txy (substr str1 i 1)) 
         i (1+ i) 
         ) 
       );;;;repeat 
       (setq str (strcat txz newtx txy)) 
      ) 
    );;;;cond 
    (setq str1 str) 
  );;;;while 
  str1 
);;;;defun|; 
 
(defun ljx-string-translate (newtx oldtx str / str1 strL oldL txt tx1 tx2 n1) 
  (setq str1 str 
  strL (strlen str1) 
  oldL (strlen oldtx) 
  txt "" 
  ) 
  (while (setq n1 (vl-string-search oldtx str1 )) 
    (setq tx1 (substr str1 1 n1) 
    tx2 (substr str1 (+ n1 1 oldL) (- strL (strlen tx1) oldL)) 
    txt (strcat txt tx1 newtx) 
    ) 
    (setq str1 tx2 
    strL (strlen str1) 
    ) 
  ) 
  (setq txt (strcat txt str1)) 
);;;;defun 
 
 
 
 
 
 
(defun lst->ss (lst / SS X) 
  ;图元转选择集 
  (if (and lst (setq lst (vl-remove nil lst))(setq 
         lst (VL-REMOVE-IF-NOT (FUNCTION (LAMBDA (A) (ENTGET A))) lst) 
       )) 
    (progn 
      (setq ss (ssadd)) 
      (last 
    (mapcar(function(lambda (x) (ssadd x ss)))lst) 
      ) 
    ) 
  ) 
  SS 
) 
 
(defun $ocr-dwg$ (ss  ) 
  (setq qz (vl-filename-mktemp "ocr" (getvar "SAVEFILEPATH")) ) ;前缀(vl-filename-mktemp "ocr" (getenv "temp")) 
  (setq png-p (strcat qz ".png"))  ;图片文件名 
  (setq txt-p (strcat qz ".txt"))  ;txt文件名 
  ;(setq ss  (ssget ) )      ;提示用户框选pdf图元  SS在主函数中"_P" 
  (VL-CMDF "PNGOUT" png-p ss "") ;输出图片 
 
  (SETQ EXE-P (findfile "Windows.Media.Ocr.Cli.exe")) 
(vl-cmdf "shell" (strcat  "Windows.Media.Ocr.Cli.exe"  " " (ljx-string-translate "/" "\\" png-p) " " " > " (ljx-string-translate "/" "\\" txt-p) )) 
   
   
   
   
  (setq i 0) 
  (setq go t) 
  (while (and go (
    (if (setq f (vl-catch-all-apply 'open (list txt-p "r"))) 
          ;开启txt文件准备读取字串 
      (while 
        (setq str (vl-catch-all-apply 'read-line (list f))) 
          ;逐行读取 
         (if str 
     (setq go nil) 
         )      ;一旦读取到了字串就让while结束循环 
         (setq strs (cons str strs)) ;字串记录 
      ) 
    ) 
    (vl-catch-all-apply 'close (list f)) ;关闭文件 
    (setq i (1+ i)) 
  ) 
  (setq strs (vl-remove '"" strs)) ;删除空行 
  (setq strs (reverse strs))  ;颠倒过来 
       
    
   
  (and ss(setq ents(vl-remove-if(function listp)(mapcar (function cadr) (ssnamex SS)))));选择集转图元 
  (setq jbs(mapcar(function(lambda(a)(cdr(assoc 5(entget a)))))ents));获取句柄 
  (if ss(SETQ BOX (getbox SS NIL))) 
  (vl-catch-all-apply 'vl-file-delete (list png-p)) ;删除图片文件 
  (vl-catch-all-apply 'vl-file-delete (list txt-p)) ;删除txt文件 
  (setq ss nil) 
  (LIST (CONS "坐标" BOX) (cons "字串" strs)(cons "图元句柄" jbs));返回 
) 
 
(defun getbox (xzj         QJBLM           /             i               xdir 
               ydir         zdir           origin    wcsOrg    UcsFlag 
               matLst         matrix           revMat    sel       ent 
               obj         minPt           maxPt     minLs     maxLs 
               maxX         maxY           minX             minY 
               Make-Rectange-getbox             dxf $GetMatrix$ 
              ) 
;;; ;诡异的填充 
                                        ;(ENTMAKE (QUOTE ((0 . HATCH) (100 . AcDbEntity) (100 . AcDbHatch) (10 0.0 0.0 0.0) (210 0.0 0.0 1.0) (2 . SOLID) (70 . 1) (71 . 0) (91 . 1) (92 . 1) (93 . 1) (72 . 2) (10 3.67321e-006 -1.0 0.0) (40 . 1.0) (50 . 1.5708) (51 . 1.5708) (73 . 1) (97 . 0) (75 . 0) (76 . 1) (98 . 1) (10 97.2 305.1 0.0))))会导致外包围错误 
  ;;先判断UCS是否与WCS相同。如是则取得UCS的X方向， 
  ;;Y方向，Z方向，UCS原点及WCS的原点相对UCS的坐标点 
  ;;然后得到UCS变换矩阵和到WCS的逆变换矩阵 
                                        ;QJBLM  全局使用的变量名（字符串格式）,这个将作为全局变量名供很多地方调用 
  (defun Make-Rectange-getbox (PTT1 PTT2 QJBLM) 
;;;    ;构造矩形 
;;;    (IF (/= $EF-tzqy(vl-princ-to-string(list(list (car PTT1) (cadr PTT1))(list (car PTT2) (cadr PTT1))(list (car PTT2) (cadr PTT2))(list (car PTT1) (cadr PTT2)))))(ALERT "变了哦")) 
    (set (read QJBLM) 
         (vl-princ-to-string 
           (list (list (car PTT1) (cadr PTT1)) 
                 (list (car PTT2) (cadr PTT1)) 
                 (list (car PTT2) (cadr PTT2)) 
                 (list (car PTT1) (cadr PTT2)) 
           ) 
         )                                ;将坐标点赋值给QJBLM 
    ) 
;;;  (TTEDIT (entlast) "zx-tzqy" (cons 1000 (vl-princ-to-string(list(list (car PTT1) (cadr PTT1))(list (car PTT2) (cadr PTT1))(list (car PTT2) (cadr PTT2))(list (car PTT1) (cadr PTT2))))) "del") 
  ) 
  (defun $GetMatrix$ (lst org Revflag / mat i j) 
  (setq mat (vlax-make-safearray vlax-vbDouble '(0 . 3) '(0 . 3))) 
                                        ;初始化一个4X4的矩阵 
  (setq i 0) 
  (repeat 3 
    (vlax-safearray-put-element mat i 3 (nth i org)) ;平移变换 
    (setq j 0) 
    (repeat 3 
      (if RevFlag 
        (vlax-safearray-put-element mat i j (nth j (nth i lst))) 
                                        ;角度逆变换 
        (vlax-safearray-put-element mat i j (nth i (nth j lst))) 
                                        ;角度的变换 
      ) 
      (setq j (1+ j)) 
    ) 
    (setq i (1+ i)) 
  ) 
  (vlax-safearray-put-element mat 3 3 1) 
  mat                                        ;返回矩阵 
) 
  (defun G:CrossProductor        (vec1 vec2 / a b c d e f) 
  ;;;   ;两矢量的叉积 
  (setq a (car vec1)) 
  (setq b (cadr vec1)) 
  (setq c (caddr vec1)) 
  (setq d (car vec2)) 
  (setq e (cadr vec2)) 
  (setq f (caddr vec2)) 
  (list 
    (- (* b f) (* c e)) 
    (- (* c d) (* a f)) 
    (- (* a e) (* b d)) 
  ) 
) 
  (if (and 
        xzj 
        (or (and (= (TYPE XZJ) 'VLA-OBJECT) (SETQ XZJ (LST->SS (LIST (vlax-vla-object->ename XZJ))))) 
            (and (= (TYPE XZJ) 'ENAME) (SETQ XZJ (LST->SS (LIST XZJ)))) 
                                        ;如果传递进来的是一个图元，就自动转换一下 
            (and (= (TYPE XZJ) 'list) 
                 (= (TYPE (car XZJ)) 'ENAME) 
                 (SETQ XZJ (LST->SS xzj)) 
            )                                ;如果传递进来是一个图元列表ss，就自动转换选择集 
            t 
        ) 
        (= (type xzj) 'pickset) 
        (or (and qjblm (= (type qjblm) 'str) (> (strlen qjblm) 1)) 
            (not qjblm) 
        ) 
      ) 
    (progn 
      (setq UcsFlag (getvar "WORLDUCS")) 
      (if (= UcsFlag 0)                        ;UCS是否与WCS相同 
        (setq UcsFlag T                        ;设置标志位为true 
              xdir    (getvar "UCSXDIR") ;X方向矢量 
              ydir    (getvar "UCSYDIR") ;Y方向矢量 
              zdir    (G:CrossProductor xdir ydir) 
                                        ;X和Y的方向矢量的叉积 
              origin  (getvar "UCSORG")        ;原点 
              WcsOrg  (trans '(0 0 0) 0 1) ;WCS的原点相对UCS的坐标 
              matLst  (list xdir ydir zdir) ;旋转的变换矩阵表 
              matrix  ($GetMatrix$ matLst origin nil) 
                                        ;从WCS到UCS的变换矩阵 
              revMat  ($GetMatrix$ matLst WcsOrg T) ;从UCS到WCS的变换矩阵 
        ) 
        (setq UcsFlag nil)                ;否则不予变换 
      ) 
      ;;在UCS下先变换物体到WCS下，取得每个物体的包围框， 
      ;;求出包围框集合的最小XY，最大XY，并用矩形框画出来 
      ;;然后把物体变换回到UCS，并把矩形也变换回去 
      (if (setq sel xzj) 
        ;;选择物体 
        (progn 
          (setq i 0) 
          (setq minPt (vlax-make-safearray vlax-vbdouble '(0 . 2))) 
                                        ;左下角点 
          (setq maxPt (vlax-make-safearray vlax-vbdouble '(0 . 2))) 
                                        ;右上角点 
          (repeat (sslength sel) 
            (if        (and (setq dxf nil 
                           dxf (entget (setq ent (ssname sel i))) 
                     )                        ;图元 
                     (or (AND (WCMATCH (CDR (ASSOC 0 DXF)) "*TEXT") 
                              (WCMATCH (CDR (ASSOC 1 DXF)) "[, ,,]") 
                                        ;空格或者是空值“” 
                         )                ;如果一个空格文字的话                         
                         (and (= (cdr (assoc 0 dxf)) "HATCH") 
                              (= (cdr (assoc 93 dxf)) 1) 
                         )                ;反正93等于1的时候不能创建填充，但是遇到诡异的填充，93等于1就可以创建，既然93在诡异的情况下可以创建，那就用93=1来排除它，诡异的填充在这里：;(ENTMAKE (QUOTE ((0 . HATCH) (100 . AcDbEntity) (100 . AcDbHatch) (10 0.0 0.0 0.0) (210 0.0 0.0 1.0) (2 . SOLID) (70 . 1) (71 . 0) (91 . 1) (92 . 1) (93 . 1) (72 . 2) (10 3.67321e-006 -1.0 0.0) (40 . 1.0) (50 . 1.5708) (51 . 1.5708) (73 . 1) (97 . 0) (75 . 0) (76 . 1) (98 . 1) (10 97.2 305.1 0.0)))) 
                     ) 
                ) 
              ()                        ;以上条件成立以后，啥也不敢干呀 
              (PROGN 
                (setq obj (vlax-ename->vla-object ent)) ;obj对象 
                (and UcsFlag (vla-TransformBy obj revMat)) 
                                        ;反变换到WCS 
;;;                    (vla-GetBoundingBox obj 'minpt 'maxpt) 
                (and (not (vl-catch-all-error-p 
                            (vl-catch-all-apply 
                              'vla-GetBoundingBox 
                              (list obj 'minPt 'maxPt) 
                            ) 
                          ) 
                     )                        ;得到包围框 
                     (setq minPt (vlax-safearray->list minPt)) 
                     (setq maxPt (vlax-safearray->list maxPt)) 
                     (setq minLs (cons minPt minLs)) ;得到左下角点表 
                     (setq maxLs (cons maxPt maxLs)) ;得到右上角点表 
                ) 
                (and UcsFlag (vla-TransformBy obj matrix)) 
                                        ;变换回到UCS 
              ) 
            ) 
            (setq i (1+ i)) 
          ) 
          (and minLs 
               (setq minX (apply 'min (mapcar 'car minLs))) 
                                        ;最小点集的最小X 
               (setq minY (apply 'min (mapcar 'cadr minLs))) 
                                        ;最小点集的最小Y 
          ) 
          (and maxLs 
               (setq maxX (apply 'max (mapcar 'car maxLs))) 
                                        ;最大点集的最小X 
               (setq maxY (apply 'max (mapcar 'cadr maxLs))) 
                                        ;最打点集的最小Y 
          ) 
          (and QJBLM 
               (Make-Rectange-getbox 
                 (list minX minY 0) 
                 (list maxX maxY 0) 
                 QJBLM 
               ) 
          )                                ;构造边框 
;;;          (and                                 
;;;            UcsFlag                        ;如果UCS的话 
;;;            (vla-TransformBy 
;;;              (vlax-ename->vla-object (entlast)) 
;;;              matrix                        ;变换边框到UCS 
;;;            ) 
;;;          ) 
        ) 
      ) 
    ) 
  ) 
  (IF (AND minX minY maxX maxY) 
    (list (list minX minY 0) (list maxX maxY 0)) 
  ) 
) 
(defun c:ocr123 (/ 1/2p 1/2p-n bl box box-new ent ents html jbs l obj result s sbjg ss str strs) 
  (setq sbjg ($ocr-dwg$ (ssget))) 
  (SETQ BOX(CDR(ASSOC "坐标" sbjg))) 
  (setq strs (cdr (assoc "字串" sbjg))) 
  (if strs 
    (progn 
       (setq jbs(cdr(assoc "图元句柄" sbjg))) 
  (setq ents(mapcar 'handent jbs)) 
  (setq ss (ssadd)) 
  (mapcar(function(lambda (x) (ssadd x ss)))ents) 
  (if ss(vl-cmdf "change" ss "" "P" "C" 1 "")) 
  (setq ss nil) 
  (setq s nil) 
  (while (setq str (car strs)) 
    (if  s 
      (setq s (strcat s "\n" str)) 
      (setq s str) 
    ) 
    (setq strs (cdr strs)) 
  ) 
  (setq str s) 
  (SETQ L(ABS(APPLY '-(MAPCAR 'CAR BOX)))) 
  (SETQ L(* L 0.8)) 
  (setq OBJ (vla-addmtext(vla-get-modelSpace(vla-get-ActiveDocument (vlax-get-acad-object)))(vlax-3d-point (list 0 0 0))(vlax-make-variant L 5)str))   
  (SETQ ENT(VLAX-VLA-OBJECT->ENAME OBJ)) 
  (SETQ BOX-NEW(GETBOX ENT NIL)) 
  (SETQ BL(/(ABS(distance(car BOX)(cadr box)))(ABS(distance(car BOX-NEW)(cadr BOX-NEW))))) 
  (setq 1/2p(mapcar(function(lambda(x y)(* (+ x y)0.5)))(car BOX)(cadr BOX))) 
  (setq 1/2p-n(mapcar(function(lambda(x y)(* (+ x y)0.5)))(car BOX-NEW)(cadr BOX-NEW))) 
  (vla-ScaleEntity OBJ(vlax-3D-point 1/2p-n)bl) 
  (vla-move obj (vlax-3d-point 1/2p-n) (vlax-3d-point 1/2p)) 
       (setq  html   (vlax-create-object "htmlfile") 
  result (vlax-invoke 
     (vlax-get (vlax-get html 'ParentWindow) 
         'ClipBoardData 
     ) 
     'setData 
     "Text" 
     str 
         ) 
  ) 
  (vlax-release-object html) 
    ) 
  ) 
 
 obj 
)

雨的节奏 · 发表于 2023-6-10 08:59:22

很牛逼，win7用户路过

TLQ · 发表于 2023-6-10 09:00:46

错误: no function definition: GETBOX

TLQ · 发表于 2023-6-10 09:04:59

缺GETBOX函数，版主能不能把这个函数发出来

dcl1214 · 发表于 2023-6-10 09:05:06

TLQ 发表于 2023-6-10 09:00
错误: no function definition: GETBOX

已经补充了

dcl1214 · 发表于 2023-6-10 09:06:46

TLQ 发表于 2023-6-10 09:04
缺GETBOX函数，版主能不能把这个函数发出来

已经补充了

dhl · 发表于 2023-6-10 10:14:59

我win10上找不到OCR.EXE

广易精通 · 发表于 2023-6-10 10:39:26

非常支持楼主

hzyhzjjzh · 发表于 2023-6-10 13:03:13

感谢大佬整理分享

账号		自动登录	找回密码
密码			注册

[源码] ocr图片识别研究

本帖子中包含更多资源

评分

评分

dcl1214 dcl1214 当前离线积分 16366 明经币个注册时间 2011-9-11 在线时间小时威望金钱个贡献激情	发表于 2023-6-10 08:53:10 \| 显示全部楼层 \|阅读模式购买主题已有 17 人购买本主题需向作者支付 3 个明经币才能浏览 "觉得好，就打赏" 打赏还没有人打赏，支持一下

	回复使用道具举报置顶卡变色卡显身卡